Change: dom-nodes have a parent slot; update dom var

2 files changed, 67 insertions, 72 deletions

diff --git a/src/dom-transform.lisp b/src/dom-transform.lisp
index 52982ae..803a7f4 100644
--- a/src/dom-transform.lisp
+++ b/src/dom-transform.lisp
@@ -1,28 +1,9 @@
 (in-package #:hypnotisml)
 
-(defun var-pair-p (thing)
+(defun var-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))))
+       (= 1 (length thing))
+       (symbolp (car thing))))
 
 (defun make-queue (&rest xs)
   (let ((q (cons nil nil)))
@@ -51,64 +32,71 @@
 (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)
+(defun ensure-parent (parent nodes)
+  (loop :for node :in nodes :do (setf (parent node) parent)))
+
+(defun expand-walk (top node clauses)
+  (a:with-gensyms (new-children frontier top-var parent)
+    (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
+                                        (let ((,node ,phrase-body))
+                                          (setf (parent ,node) ,parent)
+                                          (push ,node ,new-children)))
+                                      conditional-exprs))
+                               (:splice
+                                (push `(,guard
+                                        (let ((,node ,phrase-body))
+                                          (ensure-parent ,parent ,node)
+                                          (setf ,new-children
+                                                (nconc (reverse ,node) ,new-children))))
+                                      conditional-exprs))))))))
+          :finally (return (values (nreverse unconditional-exprs)
+                                   (nreverse conditional-exprs)
+                                   (nreverse remove-check-exprs))))
+      `(let ((,top-var ,top))
          (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)))))
+           :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>)
+                (:@ var <var-declare>)
                 (:@ clauses (:+ <clause>)) (:eof))
-   :then (expand-walk top vars clauses))
+   :then (expand-walk top var clauses))
   (<var-declare>
    :match (:item)
-   :if var-pair-p
-   :note "Variable declaration (node var)")
+   :if var-p
+   :then #'car
+   :note "Variable declaration (node)")
   (<clause>
    :match (:or <if-clause> <unconditional-clause>))
   (<unconditional-clause>
diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp
index b209fc9..b5d8823 100644
--- a/src/hypnotisml.lisp
+++ b/src/hypnotisml.lisp
@@ -61,6 +61,7 @@
   (format stream "~{~a=~s~^ ~}" (attribs-list ob)))
 
 (def:class dom-node ()
+  (parent :type (or null elem))
   :documentation "Root class for all dom-nodes")
 
 (defun dom-node-p (x) (typep x 'dom-node))
@@ -88,6 +89,12 @@
   (children :type node-list)
   :documentation "The base class for all UI elements.")
 
+(defmethod initialize-instance :around ((elem elem) &key)
+  (call-next-method)
+  (loop :for child :in (children elem)
+        :do (setf (parent child) elem))
+  elem)
+
 (defun elem-query-selector (elem)
   "Returns a CSS query selector string for the ELEM. ELEMs can be
 uniquely quried in the dom by passing string to .querySelector()"