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 UNION: nullable-string string POSTPONE: f ;
11 { space nullable-string }
13 { url nullable-string } ;
16 : ?= ( object/f object/f -- ? )
17 2dup and [ = ] [ 2drop t ] if ;
19 : names-match? ( name1 name2 -- ? )
20 [ [ space>> ] bi@ ?= ]
22 [ [ main>> ] bi@ ?= ] 2tri and and ;
24 : <simple-name> ( string -- name )
27 : <null-name> ( string -- name )
30 : assure-name ( string/name -- name )
31 dup name? [ <null-name> ] unless ;
33 TUPLE: attrs { alist sequence } ;
36 : attr@ ( key alist -- index {key,value} )
37 [ assure-name ] dip alist>>
38 [ first names-match? ] with find ;
41 attr@ nip [ second t ] [ f f ] if* ;
46 [ assure-name swap 2array ] dip
47 [ alist>> ?push ] keep (>>alist)
50 M: attrs assoc-size alist>> length ;
51 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
52 M: attrs >alist alist>> ;
54 : >attrs ( assoc -- attrs )
57 [ [ assure-name ] dip ] assoc-map
60 drop dup attrs? [ >attrs ] unless ;
65 tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
68 alist>> clone <attrs> ;
72 TUPLE: opener { name name } { attrs attrs } ;
75 TUPLE: closer { name name } ;
78 TUPLE: contained { name name } { attrs attrs } ;
79 C: <contained> contained
81 TUPLE: comment { text string } ;
86 TUPLE: element-decl < directive
87 { name string } { content-spec string } ;
88 C: <element-decl> element-decl
90 TUPLE: attlist-decl < directive
91 { name string } { att-defs string } ;
92 C: <attlist-decl> attlist-decl
94 UNION: boolean t POSTPONE: f ;
96 TUPLE: entity-decl < directive
100 C: <entity-decl> entity-decl
102 TUPLE: system-id { system-literal string } ;
103 C: <system-id> system-id
105 TUPLE: public-id { pubid-literal string } { system-literal string } ;
106 C: <public-id> public-id
108 UNION: id system-id public-id POSTPONE: f ;
110 TUPLE: doctype-decl < directive
113 { internal-subset sequence } ;
114 C: <doctype-decl> doctype-decl
116 TUPLE: notation-decl < directive name id ;
117 C: <notation-decl> notation-decl
119 TUPLE: instruction { text string } ;
120 C: <instruction> instruction
125 { standalone boolean } ;
131 { children sequence } ;
133 : <tag> ( name attrs children -- tag )
134 [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
137 ! For convenience, tags follow the assoc protocol too (for attrs)
138 CONSULT: assoc-protocol tag attrs>> ;
141 ! They also follow the sequence protocol (for children)
142 CONSULT: sequence-protocol tag children>> ;
143 INSTANCE: tag sequence
145 CONSULT: name tag name>> ;
149 [ name>> ] keep attrs>>
150 rot dup [ V{ } like ] when <tag>
153 MACRO: clone-slots ( class -- tuple )
156 [ name>> reader-word '[ _ execute clone ] ] map
158 ] [ '[ _ boa ] ] bi compose ;
170 CONSULT: sequence-protocol xml body>> ;
171 INSTANCE: xml sequence
173 CONSULT: assoc-protocol xml body>> ;
176 CONSULT: tag xml body>> ;
178 CONSULT: name xml body>> ;
181 : tag>xml ( xml tag -- newxml )
182 [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
185 : seq>xml ( xml seq -- newxml )
186 over body>> like tag>xml ;
193 swap dup xml? [ nip ] [
194 dup tag? [ tag>xml ] [ seq>xml ] if
197 ! tag with children=f is contained
198 : <contained-tag> ( name attrs -- tag )
201 PREDICATE: contained-tag < tag children>> not ;
202 PREDICATE: open-tag < tag children>> ;