repos
/
Oh, Ducks!
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Add support for XMLS-style lists, conflicting with LHTML-style lists
Annotate for file /traversal/xmls.lisp
2011-07-03 pix
1
;;; WARNING: This conflicts with lhtml.
08:25:45 '
2
(in-package #:oh-ducks.traversal)
'
3
'
4
(defvar *xmls-family-tree* nil)
'
5
'
6
(defun in-hash (key hash)
'
7
(multiple-value-bind (val present-p) (gethash key hash)
'
8
(declare (ignore val))
'
9
present-p))
'
10
'
11
(defun %mark-parents (parent children)
'
12
(dolist (item children)
'
13
(setf (gethash item *xmls-family-tree*) parent)
'
14
(%mark-parents item (element-children item))))
'
15
'
16
;; WARNING: This won't produce sane results for nested (match)es, because we
'
17
;; have no way to bind in a large enough scope.
'
18
(defmethod unify:unify ((template oh-ducks::css-selector-template)
'
19
(element list)
'
20
&optional (env (unify:make-empty-environment))
'
21
&key)
'
22
(if (and *xmls-family-tree*
'
23
(in-hash element *xmls-family-tree*))
'
24
(call-next-method)
'
25
(let ((*xmls-family-tree* (make-hash-table :test 'eq)))
'
26
(%mark-parents nil (list element))
'
27
(%mark-parents element (element-children element))
'
28
(call-next-method))))
'
29
'
30
(defmethod unify:unify ((document list) (template oh-ducks::css-selector-template)
'
31
&optional (env (unify:make-empty-environment))
'
32
&key)
'
33
(unify:unify template document env))
'
34
'
35
;;; general accessors
'
36
'
37
(defmethod element-children ((element list))
'
38
(remove-if-not (lambda (x) (and (listp x) (stringp (car x))))
'
39
(cddr element)))
'
40
'
41
(defmethod element-parent ((element list))
'
42
(multiple-value-bind (parent present?)
'
43
(gethash element *xmls-family-tree*)
'
44
(if present?
'
45
parent
'
46
(error "unable to determine parent"))))
'
47
'
48
#+(or)
'
49
(defmethod element-attribute ((attribute symbol) (element list))
'
50
(cadr (assoc attribute (cadr element))))
'
51
(defmethod element-attribute ((attribute string) (element list))
'
52
(cadr (assoc attribute (cadr element) :test #'string=)))
'
53
'
54
(defmethod element-type ((element list))
'
55
(car element))
'
56
'
57
(defmethod element-content ((element list))
'
58
(cddr element))