diff options
| -rw-r--r-- | src/dom-transform.lisp | 132 | ||||
| -rw-r--r-- | src/hypnotisml.lisp | 7 |
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()" |