-
-
Notifications
You must be signed in to change notification settings - Fork 9
/
engine.lisp
412 lines (383 loc) · 19.6 KB
/
engine.lisp
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
(in-package #:org.shirakumo.clss)
(defvar *pseudo-selectors* (make-hash-table :test 'equalp)
"Hash table for pseudo selector functions.
Links string names to functions of one or more arguments.")
(defun pseudo-selector (name)
"Returns the pseudo-selector function associated with NAME, if any."
(gethash (string name) *pseudo-selectors*))
(defun (setf pseudo-selector) (function name)
"Sets FUNCTION as the pseudo-selector for NAME."
(setf (gethash (string name) *pseudo-selectors*)
function))
(defun remove-pseudo-selector (name)
"Removes the pseudo-selector associated with NAME."
(remhash (string name) *pseudo-selectors*))
(defmacro define-pseudo-selector (name (nodename &rest args-lambda) &body body)
"Define a new pseudo-selector of NAME.
NAME --- A symbol or string naming the selector (case insensitive always).
NODENAME --- A variable symbol the matched node is bound to.
ARGS-LAMBDA --- A lambda-list of the expected arguments for the pseudo-selector.
Note that keyword arguments make no sense in this context.
BODY ::= form*"
`(setf (pseudo-selector ,(string name))
#'(lambda (,nodename ,@args-lambda)
(declare (ignorable ,nodename))
,@body)))
(define-condition pseudo-selector-not-available (error)
((%name :initarg :name :initform (error "NAME required.") :accessor name))
(:report (lambda (c s) (format s "The ~a pseudo selector doesn't make sense in a node matching engine." (name c))))
(:documentation "Condition signalled when a pseudo selector is defined according to spec,
but makes no sense in the context of CLSS and has thus been left
unimplemented."))
(define-condition undefined-pseudo-selector (error)
((%name :initarg :name :initform (error "NAME required.") :accessor name))
(:report (lambda (c s) (format s "The ~a pseudo selector is not defined!" (name c))))
(:documentation "Condition signalled when trying to use a pseudo selector that has not
been defined. This is signalled at match-time, rather than at
selector-compile-time."))
(define-condition selector-malformed (error)
((%selector :initarg :selector :initform (error "Selector malformed.") :accessor selector))
(:report (lambda (c s) (format s "Selector is malformed: ~a" (selector c))))
(:documentation "Signalled when a selector or matcher has been found to be malformed.
This really shouldn't happen unless you're passing raw lists
for the selector to the matcher."))
(define-condition complete-match-pair (condition)
((%value :initarg :value :initform NIL :accessor value))
(:documentation "Condition signalled to immediately return from MATCH-PAIR."))
(defun find-substring (item string split)
"Returns ITEM if it is an element of STRING split by the SPLIT character."
(declare (optimize speed)
(type string item string)
(type character split))
(macrolet ((with-stringcase (var &body body)
`(typecase ,var
(simple-base-string ,@body)
((and simple-string (not simple-base-string)) ,@body)
((and string (not simple-string)) ,@body))))
(with-stringcase item
(with-stringcase string
(let ((start 0) (end 0))
(declare (type fixnum start end))
(flet ((test ()
(when (string= item string :start2 start :end2 end)
(return-from find-substring item))))
(declare (inline test))
(loop while (< end (length string))
do (let ((char (aref string end)))
(declare (type character char))
(when (char= char split)
(test)
(setf start (1+ end)))
(incf end))
finally (test) (return NIL))))))))
(declaim (ftype (function (list plump-dom:node)
(values boolean))
match-constraint))
(defun match-constraint (constraint node)
"Attempts to match the CONSTRAINT form against the node.
Returns NIL if it fails to do so, unspecified otherwise."
(declare (optimize speed))
(when (ecase (car constraint)
(:c-any
(and (not (text-node-p node))
(not (comment-p node))))
(:c-tag
(and (element-p node)
(string-equal (tag-name node) (second constraint))))
(:c-type
(typep node (second constraint)))
(:c-id
(and (element-p node)
(string-equal (attribute node "id") (second constraint))))
(:c-class
(and (element-p node)
(find-substring (second constraint) (or (attribute node "class") "") #\Space)))
(:c-attr-exists
(and (element-p node)
(not (null (attribute node (second constraint))))))
(:c-attr-equals
(and (element-p node)
(destructuring-bind (comparator attribute value) (cdr constraint)
(declare (type simple-string comparator attribute value))
(let ((attr (attribute node attribute))
(value value))
(declare (type (or null string) attr))
(when attr
(ecase (aref comparator 0)
(#\=
(string-equal attr value))
(#\~
(find-substring value attr #\Space))
(#\^
(and (<= (length value) (length attr))
(string= value attr :end2 (length value))))
(#\$
(and (<= (length value) (length attr))
(string= value attr :start2 (- (length attr) (length value)))))
(#\*
(not (null (search value attr))))
(#\|
(find-substring value attr #\-))))))))
(:c-pseudo
(and (element-p node)
(destructuring-bind (name &rest args) (cdr constraint)
(let ((pseudo (pseudo-selector name)))
(declare (type function pseudo))
(assert (not (null pseudo)) () 'undefined-pseudo-selector :name name)
(not (null (apply pseudo node args))))))))
(values t)))
(declaim (ftype (function (list plump:node)
(values boolean))
match-matcher))
(defun match-matcher (matcher node)
"Attempts to match a matcher against a node.
Returns T if all constraints match, NIL otherwise."
(declare (optimize speed))
(assert (eq (car matcher) :matcher) () 'selector-malformed matcher)
(loop for constraint in (cdr matcher)
always (match-constraint constraint node)))
(declaim (ftype (function (character list plump:node (function (plump:node) T))
(values &optional null))
match-pair-depth))
(defun match-pair-depth (combinator matcher parent matching-nodes-processor)
"Match a combinator and matcher pair against a list of nodes. For every match
the function specified in \"MATCHING-NODES-PROCESSOR\" is called with the found
match as the only argument."
(declare (optimize speed))
(handler-case
(prog1 nil
(case combinator
(#\Space
(labels ((match-recursive (nodes)
(declare ((and (vector plump:node) (not simple-array)) nodes))
(loop for node across nodes
when (match-matcher matcher node)
do (funcall matching-nodes-processor node)
when (plump:nesting-node-p node)
do (match-recursive (children node)))))
(match-recursive (children parent))))
(#\>
(loop for node across (the (and (vector plump:node) (not simple-array))
(children parent))
when (match-matcher matcher node)
do (funcall matching-nodes-processor node)))
(#\+
(let ((position (child-position parent))
(family (family parent)))
(declare (type fixnum position)
(type (and (vector plump-dom:child-node)
(not simple-array))
family))
(loop for i of-type fixnum from position below (1- (fill-pointer family))
for sibling = (aref family (1+ i))
;; This is gross. In order to properly support
;; edge cases like a foo+^bar we cannot exclude
;; anything other than these two...
do (when (and (not (text-node-p parent))
(not (comment-p parent)))
(when (match-matcher matcher sibling)
(funcall matching-nodes-processor sibling))
(return)))))
(#\~
(let ((position (child-position parent))
(family (family parent)))
(declare (type fixnum position)
(type (and (vector plump-dom:child-node)
(not simple-array))
family))
(loop for i of-type fixnum from position below (fill-pointer family)
for sibling = (aref family i)
do (when (match-matcher matcher sibling)
(funcall matching-nodes-processor sibling)
(return)))))))
(complete-match-pair (o)
(loop for node across (value o)
do (funcall matching-nodes-processor node)))))
(declaim (ftype (function (character list (and (vector plump:node) (not simple-array)))
(values (and (vector plump:node) (not simple-array)) &optional))
match-pair-breadth))
(defun match-pair-breadth (combinator matcher nodes)
"Match a combinator and matcher pair against a list of nodes.
Returns a vector of matching nodes."
(declare (optimize speed))
(handler-case
(let ((resultset (make-array (length nodes) :adjustable T :fill-pointer 0)))
(case combinator
(#\Space
(labels ((match-recursive (nodes)
(declare ((and (vector plump:node) (not simple-array)) nodes))
(loop for node across nodes
when (match-matcher matcher node)
do (vector-push-extend node resultset)
when (nesting-node-p node)
do (match-recursive (children node)))))
(loop for node across nodes
do (match-recursive (children node)))))
(#\>
(loop for parent across nodes
do (loop for node across (the (and (vector plump:node) (not simple-array))
(children parent))
when (match-matcher matcher node)
do (vector-push-extend node resultset))))
(#\+
(loop for node across nodes
for position of-type fixnum = (child-position node)
for family = (family node)
do (loop for i of-type fixnum from position below (1- (fill-pointer family))
for sibling = (aref family (1+ i))
;; This is gross. In order to properly support
;; edge cases like a foo+^bar we cannot exclude
;; anything other than these two...
do (when (and (not (text-node-p node))
(not (comment-p node)))
(when (match-matcher matcher sibling)
(vector-push-extend sibling resultset))
(return)))))
(#\~
(loop for node across nodes
for position of-type fixnum = (child-position node)
for family = (family node)
do (loop for i of-type fixnum from position below (fill-pointer family)
for sibling = (aref family i)
do (when (match-matcher matcher sibling)
(vector-push-extend sibling resultset)
(return))))))
resultset)
(complete-match-pair (o)
(return-from match-pair-breadth (value o)))))
(declaim (ftype (function (list (or plump:node vector list) &optional keyword)
(values (and (vector plump:node) (not simple-array))))
match-selector))
(defun match-group (group root-node &optional (search-type :depth-first))
"Match a matcher group against the root-node and possibly all its children.
Returns an array of mached nodes."
(declare (optimize debug))
(assert (eq (car group) :group) () 'selector-malformed)
(let ((group (cdr group)))
(ecase search-type
(:depth-first
(let* ((result (make-array 10 :adjustable T :fill-pointer 0)))
(labels ((add-to-result (node)
(vector-push-extend node result))
(search-node (node group)
(let ((combinator (car group))
(matcher (cadr group))
(group (cddr group)))
(if group
(match-pair-depth combinator
matcher
node
(lambda (node)
(search-node node group)))
(match-pair-depth combinator
matcher
node
#'add-to-result)))))
(etypecase root-node
(plump:node (search-node root-node group))
(sequence (map nil
(lambda (node) (search-node node group))
root-node)))
result)))
(:breadth-first
(loop with nodes = (etypecase root-node
(plump:node (make-array 1 :initial-element root-node :adjustable T :fill-pointer T))
(vector root-node)
(list (coerce root-node 'vector)))
for combinator = (pop group)
for matcher = (pop group)
while matcher
do (setf nodes (match-pair-breadth combinator matcher nodes))
finally (return nodes))))))
(declaim (ftype (function (list (or plump:node vector list) keyword)
(values (and (vector plump:node) (not simple-array))))
match-selector))
(defun match-selector (selector root-node search-type)
"Match a selector against the root-node and possibly all its children.
Returns an array of matched nodes."
(declare (optimize speed))
(assert (eq (car selector) :selector) () 'selector-malformed)
(let ((selector (cdr selector)))
(loop with result = (match-group (pop selector) root-node search-type)
for group in selector
do (array-utils:vector-append result (match-group group root-node search-type))
finally (return result))))
(declaim (ftype (function ((or string list) (or plump:node vector list) &optional keyword)
(values (and (vector plump:node) (not simple-array)) &optional))
select))
(defun select (selector root-node &optional (search-type :depth-first))
"Match the given selector against the root-node and possibly all its children.
Returns an array of matched nodes.
SELECTOR --- A CSS-selector string or a compiled selector list.
ROOT-NODE --- A single node, list or vector of nodes to start matching from.
SEARCH-TYPE --- Select the search algorithm, options are \":depth-first\" and \":breadth-first\"."
(match-selector (ensure-selector selector) root-node search-type))
(define-compiler-macro select (&whole whole &environment env selector root-node &optional (search-type :depth-first))
(if (constantp selector env)
`(match-selector (load-time-value (ensure-selector ,selector)) ,root-node ,search-type)
whole))
(declaim (ftype (function (list plump:node) boolean) match-group-backwards))
(defun match-group-backwards (group node)
(declare (optimize speed))
(assert (eql (car group) :group) () 'selector-malformed)
(let ((group (reverse (cdr group))))
(when (match-matcher (pop group) node)
(loop for combinator = (pop group)
for matcher = (pop group)
while matcher
do (case combinator
(#\Space
(loop do (setf node (parent node))
(when (or (not node) (root-p node))
(return-from match-group-backwards NIL))
until (match-matcher matcher node)))
(#\>
(setf node (parent node))
(unless (and node (not (root-p node)) (match-matcher matcher node))
(return-from match-group-backwards NIL)))
(#\+
(setf node (previous-element node))
(unless (and node (match-matcher matcher node))
(return-from match-group-backwards NIL)))
(#\~
(loop for i of-type fixnum downfrom (child-position node) above 0
for sibling = (aref (family node) i)
do (when (match-matcher matcher sibling)
(setf node sibling)
(return))
finally (return-from match-group-backwards NIL))))
finally (return T)))))
(declaim (ftype (function (T plump:node) boolean) node-matches-p))
(defun node-matches-p (selector node)
"Tests whether the node matches the selector.
SELECTOR --- A CSS-selector string or a compiled selector list.
NODE --- The node to test."
(declare (optimize speed))
(let ((selector (ensure-selector selector)))
(assert (eql (car selector) :selector) () 'selector-malformed)
(loop for group in (cdr selector)
thereis (match-group-backwards group node))))
(define-compiler-macro node-matches-p (&whole whole &environment env selector root-node)
(if (constantp selector env)
`(node-matches-p (load-time-value (ensure-selector ,selector)) ,root-node)
whole))
(defun ordered-select (selector root-node)
"Match the given selector against the root-node and possibly all its children.
Return an array of matching nodes ordered by their depth-first
traversal appearance in the DOM.
SELECTOR --- A CSS-selector string or a compiled selector list.
ROOT-NODE --- A single node, list or vector of nodes to start matching from."
(declare (optimize speed))
(let ((matched-nodes (make-array 0 :adjustable T :fill-pointer 0))
(selector (ensure-selector selector)))
(assert (eql (car selector) :selector) () 'selector-malformed)
(labels ((collect-if-match (element)
(when (clss:node-matches-p selector element)
(vector-push-extend element matched-nodes))
(map NIL #'collect-if-match (plump:child-elements element))))
(collect-if-match root-node)
matched-nodes)))
(define-compiler-macro ordered-select (&whole whole &environment env selector root-node)
(if (constantp selector env)
`(ordered-select (load-time-value (ensure-selector ,selector)) ,root-node)
whole))