1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
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."))
|
