1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences sequences.private assocs arrays
4 delegate.protocols delegate vectors ;
7 TUPLE: name space tag url ;
10 : ?= ( object/f object/f -- ? )
11 2dup and [ = ] [ 2drop t ] if ;
13 : names-match? ( name1 name2 -- ? )
14 [ name-space swap name-space ?= ] 2keep
15 [ name-url swap name-url ?= ] 2keep
16 name-tag swap name-tag ?= and and ;
18 : <name-tag> ( string -- name )
21 : assure-name ( string/name -- name )
22 dup name? [ <name-tag> ] unless ;
24 TUPLE: opener name attrs ;
30 TUPLE: contained name attrs ;
31 C: <contained> contained
36 TUPLE: directive text ;
37 C: <directive> directive
39 TUPLE: instruction text ;
40 C: <instruction> instruction
42 TUPLE: prolog version encoding standalone ;
45 TUPLE: tag attrs children ;
50 : attr@ ( key alist -- index {key,value} )
51 >r assure-name r> attrs-alist
52 [ first names-match? ] with find ;
55 attr@ nip [ second t ] [ f f ] if* ;
60 >r assure-name swap 2array r>
61 [ attrs-alist ?push ] keep set-attrs-alist
64 M: attrs assoc-size attrs-alist length ;
65 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
66 M: attrs >alist attrs-alist ;
68 : >attrs ( assoc -- attrs )
71 [ >r assure-name r> ] assoc-map
74 drop dup attrs? [ >attrs ] unless ;
77 f swap set-attrs-alist ;
79 tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
82 attrs-alist clone <attrs> ;
86 : <tag> ( name attrs children -- tag )
87 >r >r assure-name r> T{ attrs } assoc-like r>
88 { set-delegate set-tag-attrs set-tag-children }
91 ! For convenience, tags follow the assoc protocol too (for attrs)
92 CONSULT: assoc-protocol tag tag-attrs ;
95 ! They also follow the sequence protocol (for children)
96 CONSULT: sequence-protocol tag tag-children ;
97 INSTANCE: tag sequence
101 [ delegate ] keep tag-attrs
102 rot dup [ V{ } like ] when <tag>
106 [ delegate clone ] keep [ tag-attrs clone ] keep
108 { set-delegate set-tag-attrs set-tag-children } tag construct ;
110 TUPLE: xml prolog before main after ;
111 : <xml> ( prolog before main after -- xml )
112 { set-xml-prolog set-xml-before set-delegate set-xml-after }
115 CONSULT: sequence-protocol xml delegate ;
116 INSTANCE: xml sequence
118 CONSULT: assoc-protocol xml delegate ;
122 : tag>xml ( xml tag -- newxml )
123 swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
125 : seq>xml ( xml seq -- newxml )
126 over delegate like tag>xml ;
130 [ xml-prolog clone ] keep [ xml-before clone ] keep
131 [ delegate clone ] keep xml-after clone <xml> ;
134 swap dup xml? [ nip ] [
135 dup tag? [ tag>xml ] [ seq>xml ] if
138 ! tag with children=f is contained
139 : <contained-tag> ( name attrs -- tag )
142 PREDICATE: contained-tag < tag tag-children not ;
143 PREDICATE: open-tag < tag tag-children ;