summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/dom-transform.lisp132
-rw-r--r--src/hypnotisml.lisp7
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()"