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 ;
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 : assure-name ( string/name -- name )
23 dup name? [ <simple-name> ] unless ;
25 TUPLE: opener name attrs ;
31 TUPLE: contained name attrs ;
32 C: <contained> contained
37 TUPLE: directive text ;
38 C: <directive> directive
40 TUPLE: instruction text ;
41 C: <instruction> instruction
43 TUPLE: prolog version encoding standalone ;
49 : attr@ ( key alist -- index {key,value} )
50 >r assure-name r> alist>>
51 [ first names-match? ] with find ;
54 attr@ nip [ second t ] [ f f ] if* ;
59 >r assure-name swap 2array r>
60 [ alist>> ?push ] keep (>>alist)
63 M: attrs assoc-size alist>> length ;
64 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
65 M: attrs >alist alist>> ;
67 : >attrs ( assoc -- attrs )
70 [ >r assure-name r> ] assoc-map
73 drop dup attrs? [ >attrs ] unless ;
78 tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
81 alist>> clone <attrs> ;
85 TUPLE: tag name attrs children ;
87 : <tag> ( name attrs children -- tag )
88 [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
91 ! For convenience, tags follow the assoc protocol too (for attrs)
92 CONSULT: assoc-protocol tag attrs>> ;
95 ! They also follow the sequence protocol (for children)
96 CONSULT: sequence-protocol tag children>> ;
97 INSTANCE: tag sequence
99 CONSULT: name tag name>> ;
103 [ name>> ] keep attrs>>
104 rot dup [ V{ } like ] when <tag>
107 MACRO: clone-slots ( class -- tuple )
110 [ name>> reader-word 1quotation [ clone ] compose ] map
112 ] [ [ boa ] curry ] bi compose ;
117 TUPLE: xml prolog before body after ;
120 CONSULT: sequence-protocol xml body>> ;
121 INSTANCE: xml sequence
123 CONSULT: assoc-protocol xml body>> ;
126 CONSULT: tag xml body>> ;
128 CONSULT: name xml body>> ;
131 : tag>xml ( xml tag -- newxml )
132 >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
135 : seq>xml ( xml seq -- newxml )
136 over body>> like tag>xml ;
143 swap dup xml? [ nip ] [
144 dup tag? [ tag>xml ] [ seq>xml ] if
147 ! tag with children=f is contained
148 : <contained-tag> ( name attrs -- tag )
151 PREDICATE: contained-tag < tag children>> not ;
152 PREDICATE: open-tag < tag children>> ;