1 ! Copyright (C) 2005, 2009 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 accessors multiline
5 macros words quotations combinators slots fry strings ;
8 TUPLE: interpolated var ;
9 C: <interpolated> interpolated
11 UNION: nullable-string string POSTPONE: f ;
14 { space nullable-string }
16 { url nullable-string } ;
19 : ?= ( object/f object/f -- ? )
20 2dup and [ = ] [ 2drop t ] if ;
22 : names-match? ( name1 name2 -- ? )
23 [ [ space>> ] bi@ ?= ]
25 [ [ main>> ] bi@ ?= ] 2tri and and ;
27 : <simple-name> ( string -- name )
30 : <null-name> ( string -- name )
33 : assure-name ( string/name -- name )
34 dup name? [ <null-name> ] unless ;
36 TUPLE: attrs { alist sequence } ;
39 : attr@ ( key alist -- index {key,value} )
40 [ assure-name ] dip alist>>
41 [ first names-match? ] with find ;
44 attr@ nip [ second t ] [ f f ] if* ;
49 [ assure-name swap 2array ] dip
50 [ alist>> ?push ] keep alist<<
53 M: attrs assoc-size alist>> length ;
54 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
55 M: attrs >alist alist>> ;
57 : >attrs ( assoc -- attrs )
60 [ [ assure-name ] dip ] assoc-map
63 drop dup attrs? [ >attrs ] unless ;
68 [ nip ] [ attr@ drop ] 2bi
69 [ swap alist>> remove-nth! drop ] [ drop ] if* ;
72 alist>> clone <attrs> ;
76 TUPLE: opener { name name } { attrs attrs } ;
79 TUPLE: closer { name name } ;
82 TUPLE: contained { name name } { attrs attrs } ;
83 C: <contained> contained
85 TUPLE: comment { text string } ;
90 TUPLE: element-decl < directive
92 { content-spec string } ;
93 C: <element-decl> element-decl
95 TUPLE: attlist-decl < directive
98 C: <attlist-decl> attlist-decl
100 UNION: boolean t POSTPONE: f ;
102 TUPLE: entity-decl < directive
106 C: <entity-decl> entity-decl
108 TUPLE: system-id { system-literal string } ;
109 C: <system-id> system-id
111 TUPLE: public-id { pubid-literal string } { system-literal string } ;
112 C: <public-id> public-id
114 UNION: id system-id public-id POSTPONE: f ;
117 { directives sequence }
119 { parameter-entities assoc } ;
122 UNION: dtd/f dtd POSTPONE: f ;
124 TUPLE: doctype-decl < directive
127 { internal-subset dtd/f } ;
128 C: <doctype-decl> doctype-decl
130 TUPLE: notation-decl < directive
133 C: <notation-decl> notation-decl
135 TUPLE: instruction { text string } ;
136 C: <instruction> instruction
141 { standalone boolean } ;
147 { children sequence } ;
149 : <tag> ( name attrs children -- tag )
150 [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
153 : attr ( tag/xml name -- string )
156 : set-attr ( tag/xml value name -- )
159 ! They also follow the sequence protocol (for children)
160 CONSULT: sequence-protocol tag children>> ;
161 INSTANCE: tag sequence
163 CONSULT: name tag name>> ;
167 [ name>> ] keep attrs>>
168 rot dup [ V{ } like ] when <tag>
171 MACRO: clone-slots ( class -- tuple )
174 [ name>> reader-word '[ _ execute clone ] ] map
176 ] [ '[ _ boa ] ] bi compose ;
188 CONSULT: sequence-protocol xml body>> ;
189 INSTANCE: xml sequence
191 CONSULT: tag xml body>> ;
193 CONSULT: name xml body>> ;
196 : tag>xml ( xml tag -- newxml )
197 [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
200 : seq>xml ( xml seq -- newxml )
201 over body>> like tag>xml ;
208 swap dup xml? [ nip ] [
209 dup tag? [ tag>xml ] [ seq>xml ] if
212 ! tag with children=f is contained
213 : <contained-tag> ( name attrs -- tag )
216 PREDICATE: contained-tag < tag children>> not ;
217 PREDICATE: open-tag < tag children>> ;
219 TUPLE: unescaped string ;
220 C: <unescaped> unescaped
223 tag comment string directive instruction unescaped ;
225 TUPLE: xml-chunk seq ;
226 C: <xml-chunk> xml-chunk
228 CONSULT: sequence-protocol xml-chunk seq>> ;
229 INSTANCE: xml-chunk sequence