From 84b6d6c6a7e55a606373607c054906f95d0f4ad3 Mon Sep 17 00:00:00 2001 From: Duncan Wilkie Date: Mon, 18 Sep 2023 08:33:40 -0500 Subject: Emacs Lisp -> Scheme transpiler, implementing forms.el logic. --- dnw/forms.scm | 207 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 207 insertions(+) create mode 100644 dnw/forms.scm (limited to 'dnw/forms.scm') diff --git a/dnw/forms.scm b/dnw/forms.scm new file mode 100644 index 0000000..c163267 --- /dev/null +++ b/dnw/forms.scm @@ -0,0 +1,207 @@ +(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. -- cgit v1.2.3