Emacs Lisp -> Scheme transpiler, implementing forms.el logic.

1 files changed, 207 insertions, 0 deletions

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.