Add: dom-transform

1 files changed, 132 insertions, 0 deletions

diff --git a/src/dom-transform.lisp b/src/dom-transform.lisp
new file mode 100644
index 0000000..52982ae
--- /dev/null
+++ b/src/dom-transform.lisp
@@ -0,0 +1,132 @@
+(in-package #:hypnotisml)
+
+(defun var-pair-p (thing)
+  (and (listp thing)
+       (= 2 (length thing))
+       (every #'symbolp thing)))
+
+  
+
+
+#+off
+(a:with-gensyms (elem frontier)
+  (destructuring-bind (node parent) vars
+    (let ((loop-clauses
+            (loop :for (_if cond-expr action) :in clauses
+                  :if (eq :remove)
+                    :collect `(:when ,cond-expr ))))
+      `(let* ((,elem ,elem-expr)
+              (,frontier (list ,elem)))
+         (loop
+           :until (endp ,frontier)
+           :with ,parent := nil
+           :for ,node := (car ,frontier)
+           ,@loop-clauses)
+         ,elem))))
+
+(defun make-queue (&rest xs)
+  (let ((q (cons nil nil)))
+    (when xs (enqueue* q xs))
+    q))
+
+(defun enqueue (q e)
+  (push e (cdr q)))
+
+(defun enqueue* (q es)
+  (dolist (e es) (enqueue q e)))
+
+(defun prequeue (q e)
+  (push e (car q)))
+
+(defun prequeue* (q es)
+  (dolist (e (reverse es))
+    (prequeue q e)))
+
+(defun dequeue (q)
+  (when (endp (car q))
+    (setf (car q) (nreverse (cdr q))
+          (cdr q) nil))
+  (pop (car q)))
+
+(defun empty-queue (q)
+  (not (or (car q) (cdr q))))
+
+
+(defun expand-walk (top vars clauses)
+  (a:with-gensyms (new-children frontier top-var)
+    (destructuring-bind (node parent) vars
+     (multiple-value-bind
+           (unconditional-exprs conditional-exprs remove-check-exprs)
+         (loop
+           :with unconditional-exprs := nil
+           :with conditional-exprs := nil
+           :with remove-check-exprs := nil
+           :for (clause-start . clause-body) :in clauses
+           :do (case clause-start
+                 (:do (push (first clause-body) unconditional-exprs))
+                 (:if (destructuring-bind (guard phrase) clause-body
+                        (if (eq :remove phrase)
+                            (push guard remove-check-exprs)
+                            (destructuring-bind (phrase-head phrase-body) phrase
+                              (ecase phrase-head
+                                (:replace
+                                 (push `(,guard (push ,phrase-body ,new-children))
+                                       conditional-exprs))
+                                (:splice
+                                 (push `(,guard (setf ,new-children
+                                                 (nconc (reverse ,phrase-body)
+                                                        ,new-children)))
+                                       conditional-exprs))))))))
+           :finally (return (values (nreverse unconditional-exprs)
+                                    (nreverse conditional-exprs)
+                                    (nreverse remove-check-exprs))))
+       `(let ((,top-var ,top))
+          (loop
+            :with ,frontier := (make-queue ,top-var)
+            :until (empty-queue ,frontier)
+            :for ,parent := (dequeue ,frontier)
+            :for ,new-children := (loop
+                                    :with ,new-children := nil
+                                    :for ,node :in (children ,parent)
+                                    ,@(when unconditional-exprs
+                                        (cons :do unconditional-exprs))
+                                    :unless (or ,@remove-check-exprs)
+                                      :do (cond
+                                            ,@conditional-exprs
+                                            (t (push ,node ,new-children)))
+                                    :finally (return  (nreverse ,new-children)))
+            :do (setf (children ,parent) ,new-children)
+                (enqueue* ,frontier (remove-if-not #'elemp ,new-children)))
+          ,top-var)))))
+
+(argot:deflanguage dom-transform ()
+  (<walk>
+   :match (:seq (:@ top (:item))
+                (:@ vars <var-declare>)
+                (:@ clauses (:+ <clause>)) (:eof))
+   :then (expand-walk top vars clauses))
+  (<var-declare>
+   :match (:item)
+   :if var-pair-p
+   :note "Variable declaration (node var)")
+  (<clause>
+   :match (:or <if-clause> <unconditional-clause>))
+  (<unconditional-clause>
+   :match (:seq (:= :do) (:item)))
+  (<if-clause>
+   :match (:seq (:= :if) (:item) <action-phrase>))
+  (<action-phrase>
+   :match (:or <remove-phrase> <replace-phrase> <splice-phrase>))
+  (<remove-phrase>
+   :match (:= :remove)
+   :note "Removes the node from the tree, including all its children.")
+  (<replace-phrase>
+   :match (:seq (:= :replace) (:item))
+   :note "Expression should return a DOM-NODE")
+  (<splice-phrase>
+   :match (:seq (:= :splice) (:item))
+   :note "Expression should return a list of DOM-NODEs. These will be inserted
+in place of the current node, and WALK will visit the first of these
+nodes next."))
+
+