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 accessors multiline
5 macros words quotations combinators slots fry ;
8 TUPLE: name space main url ;
11 : ?= ( object/f object/f -- ? )
12 2dup and [ = ] [ 2drop t ] if ;
14 : names-match? ( name1 name2 -- ? )
15 [ [ space>> ] bi@ ?= ]
17 [ [ main>> ] bi@ ?= ] 2tri and and ;
19 : <simple-name> ( string -- name )
22 : <null-name> ( string -- name )
25 : assure-name ( string/name -- name )
26 dup name? [ <null-name> ] unless ;
28 TUPLE: opener name attrs ;
34 TUPLE: contained name attrs ;
35 C: <contained> contained
42 TUPLE: element-decl < directive name content-spec ;
43 C: <element-decl> element-decl
45 TUPLE: attlist-decl < directive name att-defs ;
46 C: <attlist-decl> attlist-decl
48 TUPLE: entity-decl < directive name def ;
49 C: <entity-decl> entity-decl
51 TUPLE: system-id system-literal ;
52 C: <system-id> system-id
54 TUPLE: public-id pubid-literal system-literal ;
55 C: <public-id> public-id
57 TUPLE: doctype-decl < directive name external-id internal-subset ;
58 C: <doctype-decl> doctype-decl
60 TUPLE: notation-decl < directive name id ;
61 C: <notation-decl> notation-decl
63 TUPLE: instruction text ;
64 C: <instruction> instruction
66 TUPLE: prolog version encoding standalone ;
72 : attr@ ( key alist -- index {key,value} )
73 [ assure-name ] dip alist>>
74 [ first names-match? ] with find ;
77 attr@ nip [ second t ] [ f f ] if* ;
82 [ assure-name swap 2array ] dip
83 [ alist>> ?push ] keep (>>alist)
86 M: attrs assoc-size alist>> length ;
87 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
88 M: attrs >alist alist>> ;
90 : >attrs ( assoc -- attrs )
93 [ [ assure-name ] dip ] assoc-map
96 drop dup attrs? [ >attrs ] unless ;
101 tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
104 alist>> clone <attrs> ;
106 INSTANCE: attrs assoc
108 TUPLE: tag name attrs children ;
110 : <tag> ( name attrs children -- tag )
111 [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
114 ! For convenience, tags follow the assoc protocol too (for attrs)
115 CONSULT: assoc-protocol tag attrs>> ;
118 ! They also follow the sequence protocol (for children)
119 CONSULT: sequence-protocol tag children>> ;
120 INSTANCE: tag sequence
122 CONSULT: name tag name>> ;
126 [ name>> ] keep attrs>>
127 rot dup [ V{ } like ] when <tag>
130 MACRO: clone-slots ( class -- tuple )
133 [ name>> reader-word '[ _ execute clone ] ] map
135 ] [ '[ _ boa ] ] bi compose ;
140 TUPLE: xml prolog before body after ;
143 CONSULT: sequence-protocol xml body>> ;
144 INSTANCE: xml sequence
146 CONSULT: assoc-protocol xml body>> ;
149 CONSULT: tag xml body>> ;
151 CONSULT: name xml body>> ;
154 : tag>xml ( xml tag -- newxml )
155 [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
158 : seq>xml ( xml seq -- newxml )
159 over body>> like tag>xml ;
166 swap dup xml? [ nip ] [
167 dup tag? [ tag>xml ] [ seq>xml ] if
170 ! tag with children=f is contained
171 : <contained-tag> ( name attrs -- tag )
174 PREDICATE: contained-tag < tag children>> not ;
175 PREDICATE: open-tag < tag children>> ;