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
|
(in-package #:hypnotisml)
(defun var-p (thing)
(and (listp thing)
(= 1 (length thing))
(symbolp (car thing))))
(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 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)
(pushnew ,node ,new-children :test #'eq)))
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 ,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))
(:@ var <var-declare>)
(:@ clauses (:+ <clause>)) (:eof))
:then (expand-walk top var clauses))
(<var-declare>
:match (:item)
:if var-p
:then #'car
:note "Variable declaration (node)")
(<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."))
|
