(define-module (dnw forms) #:use-module (ice-9 peg) #:use-module (ice-9 textual-ports) #:use-module (ice-9 match) #:use-module (ice-9 string-fun) #:use-module (srfi srfi-1) #:export (forms.el->sxml)) ;; Idea: function that takes in a git repository link pointing to something containing a forms file pair, ;; and reads it in along with a mapping between whatever Elisp functions you use in forms-format-list ;; and equivalent Scheme implementations (bc I can't figure out how to programmatically use Guile's Elisp support). ;; It parses the .el file, creating a Scheme translation of your code, and then reimplements the forms.el logic, ;; but outputs an SHTML interface instead. ;; The necessary forms.el logic is basically: ;; - read in data from forms-file as lists based on field-separator value, ;; - filter out the list elements according to forms-read-file-filter, ;; - replace the multi-line character with newlines, ;; - iterate over the list elements, setting up a proper execution environment (defining forms-fields/forms-enumerate), ;; - map over forms-format-list, replacing numbers with the corresponding field in the list element and evaluating code blocks, ;; - put resulting string inside a corresponding display. (define-peg-string-patterns ;; An elisp "parser" that extracts relevant variables from the control file. "form-control-file <- (setq/other-sexp/whitespace)+ comment < ';' (!'\n' .)* '\n'? whitespace < (comment/[\r\n\t ])* setq <- OPEN-PAREN whitespace SETQ (whitespace name-value-pair/other-pair)* whitespace CLOSE-PAREN other-sexp < elisp-value name-value-pair <- whitespace name whitespace elisp-value other-pair < whitespace symbol whitespace elisp-value name <-- 'forms-file'/'forms-format-list'/'forms-number-of-fields'/'forms-field-sep'\ /'forms-read-only'/'forms-multi-line'/'forms-read-file-filter'/'forms-write-file-filter'\ /'forms-new-record-filter'/'forms-insert-after'/'forms-check-number-of-fields' elisp-value <- literal/function-access/quoted/quasiquoted/sexp sexp <-- OPEN-PAREN (whitespace elisp-value)* whitespace CLOSE-PAREN literal <- integer/float/character/string/symbol/vector FUNCTION-ACCESS-PREFIX < '#' ['] function-access <- FUNCTION-ACCESS-PREFIX symbol quoted <-- QUOTE elisp-value quasiquoted <-- BACKTICK OPEN-PAREN (whitespace elisp-value/whitespace unquoted)* whitespace CLOSE-PAREN unquoted <-- COMMA whitespace elisp-value integer <-- decimal/binary/octal/hex sign <- ('+'/'-') digit <- [0-9] decimal <- sign? digit+ [.]? binary <- '#b' [01]+ octdigit <- [0-7] octal <- '#o' octdigit+ hexdigit <- [0-9a-fA-F] hex <- '#x' hexdigit+ float <-- sign? digit* [.]? digit* [eE] ((sign? digit+)/'+INF'/'+NaN') / sign? digit* [.] digit+ character <- control-character/named-character/hex-character/oct-character/self-character SELF-START < '?' '\\'? self-character <-- SELF-START . NAME-START < '?\\N{' NAME-END < '}' named-character <-- NAME-START (!'}' .)+ NAME-END HEX-START < '?\\x' hex-character <-- HEX-START hexdigit+ OCT-START < '?\\' oct-character <-- OCT-START octdigit octdigit? octdigit? CONTROL-START < '?\\^' control-character <-- CONTROL-START alph string <- regular-string/propertized-string regular-string <-- '\"' ( '\\' '\"' / !'\"' .)* '\"' PROPERTIZED-START < '#(' propertized-string <-- PROPERTIZED-START whitespace regular-string (whitespace elisp-value)* whitespace CLOSE-PAREN vector <-- OPEN-BRACKET (whitespace elisp-value)* whitespace CLOSE-BRACKET symbol <-- ((!digit symbol-char) symbol-char*) symbol-char <- '-'/[0-9a-zA-Z+=*/_~!@$%^&:<>{}?.]/('\\' .) alph <- [a-zA-Z] OPEN-PAREN < '(' CLOSE-PAREN < ')' OPEN-BRACKET < '[' CLOSE-BRACKET < ']' QUOTE < ['] BACKTICK < '`' COMMA < ',' QUESTION < '?' SETQ < 'setq'") (define (walk tree symbol-remapping) (define (recurse tree2) (walk tree2 symbol-remapping)) (define (string1->character c) (car (string->list c))) (define (read-string s) (call-with-input-string s read)) (match tree (('sexp contents ...) (recurse contents)) (('quoted contents ...) (apply list (cons 'quote (recurse contents)))) (('quasiquoted contents ...) (apply list (cons 'quasiquote (recurse contents)))) (('unquoted contents ...) (apply list (cons 'unquote (recurse contents)))) (('vector contents ...) (list->vector (recurse contents))) (('integer literal) (read-string literal)) (('float literal) (cond ((string=? literal "1.0e+INF") +inf.0) ((string=? literal "-1.0e+INF") -inf.0) ((string=? literal "0.0e+NaN") +nan.0) ((string=? literal "0.0e-NaN") +nan.0) (else (read-string literal)))) (('self-character literal) (string1->character literal)) (((or 'named-character 'oct-character) literal) (read-string (string-append "#\\" literal))) (('hex-character literal) (read-string (string-append "#\\x" literal))) (('control-character literal) (integer->char (- (char->integer (char-upcase (string1->character literal))) 64))) (('regular-string literal) (read-string literal)) (('propertized-string ('regular-string literal) (properties ...)) (read-string literal)) ;; Discard properties. (('symbol literal) (let* ((symbol (string->symbol literal)) (lookup (assq-ref symbol-remapping symbol))) (if lookup lookup symbol))) (('name literal) (string->symbol literal)) ((other ...) (map recurse other)) (other other))) (define (forms.el->sxml control-file-contents data-file-contents extra-remapping) (let* ((symbol-remapping (append extra-remapping '((nil . ''()) (consp . pair?) (atom . (lambda (x) (not (pair? x)))) (listp . list?) (null . null?) (nth . (lambda (x y) (list-ref y x))) (stringp . string?) (concat . string-append) (split-string . string-split) (string= . string=?) (string-equal . string=?) (t . #t)))) (parse-alist (map (lambda (pair) (cons (car pair) (cadr pair))) (walk (peg:tree (match-pattern form-control-file control-file-contents)) symbol-remapping))) (forms-file (assq-ref parse-alist 'forms-file)) (forms-format-list (cadr (assq-ref parse-alist 'forms-format-list))) (forms-field-symbols (match (assq-ref parse-alist 'forms-number-of-fields) (('forms-enumerate ('quote symbols)) (map (lambda (x y) (cons x y)) symbols (iota (length symbols)))) (other '()))) (forms-field-sep (if (assq-ref parse-alist 'forms-field-sep) (car (string->list (assq-ref parse-alist 'forms-field-sep))) #\tab)) (forms-multi-line (if (assq-ref parse-alist 'forms-multi-line) (assq-ref parse-alist 'forms-multi-line) "\v")) (split-data (filter (lambda (x) (not (string-null? (apply string-append x)))) (map (lambda (record) (string-split (string-replace-substring record forms-multi-line " ") forms-field-sep)) (string-split data-file-contents #\newline)))) (textualized-data (map (lambda (record) (if (not (null? record)) (fold-right (lambda (x y) (if (integer? x) (string-append (number->string x) y) (string-append x y))) "" (map (lambda (format-entry) (cond ((string? format-entry) format-entry) ((integer? format-entry) (list-ref record (- format-entry 1))) ((symbol? format-entry) (list-ref record (assq-ref forms-field-symbols format-entry))) ((list? format-entry) (module-define! (current-module) 'forms-fields record) (for-each (lambda (x) (module-define! (current-module) (car x) (cdr x))) forms-field-symbols) (eval format-entry (current-module))))) forms-format-list)) "")) split-data))) `(div (@ (class "forms-carousel")) (ul ,@(map (lambda (entry) `(li (div (@ (class "form-entry")) (p ,entry)))) textualized-data))))) ;; TODO: explain that no modified characters can be parsed within the non-thrown-away variable settings. ;; TODO: explain that octal string escape characters will be parsed improperly/naively. ;; TODO: explain circular lists not supported because Scheme doesn't have read syntax for it. ;; TODO: consider how to convert propertized string literals to HTML. ;; TODO: explain that check-number-of-fields must be set and each field the correct size. ;; TODO: add option for newline replacement character re-substitution.