1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: words assocs kernel accessors parser vocabs.parser
4 effects.parser sequences summary lexer splitting combinators
5 locals memoize sequences.deep xml.data xml.state xml namespaces
6 present arrays generalizations sequences.generalizations strings
7 make math macros multiline combinators.short-circuit sorting fry
8 unicode.categories effects ;
13 ERROR: no-tag name word ;
16 drop "The tag-dispatching word has no method for the given tag name" ;
18 : compile-tags ( word xtable -- quot )
19 >alist swap '[ _ throw-no-tag ] suffix '[ dup main>> _ case ] ;
21 : define-tags ( word effect -- )
22 [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
24 :: define-tag ( string word quot -- )
25 quot string word "xtable" word-prop set-at
26 word word stack-effect define-tags ;
31 scan-new-word scan-effect
32 [ drop H{ } clone "xtable" set-word-prop ]
37 scan-token scan-word parse-definition define-tag ;
40 scan-new-word scan-token '[ f swap _ <name> ] ( string -- name ) define-memoized ;
44 : each-attrs ( attrs quot -- )
45 [ values [ interpolated? ] filter ] dip each ; inline
47 : (each-interpolated) ( ... item quot: ( ... interpolated -- ... ) -- ... )
49 { [ over interpolated? ] [ call ] }
50 { [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
51 { [ over attrs? ] [ each-attrs ] }
52 { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
54 } cond ; inline recursive
56 : each-interpolated ( xml quot -- )
57 '[ _ (each-interpolated) ] deep-each ; inline
59 : has-interpolated? ( xml -- ? )
60 ! If this becomes a performance problem, it can be improved
61 f swap [ 2drop t ] each-interpolated ;
63 : when-interpolated ( xml quot -- genquot )
64 [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
66 : string>chunk ( string -- chunk )
67 t interpolating? [ string>xml-chunk ] with-variable ;
69 : string>doc ( string -- xml )
70 t interpolating? [ string>xml ] with-variable ;
72 DEFER: interpolate-sequence
74 : get-interpolated ( interpolated -- quot )
75 var>> '[ [ _ of ] keep ] ;
77 : ?present ( object -- string )
78 dup [ present ] when ;
80 : interpolate-attr ( key value -- quot )
82 [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
83 [ 2array '[ _ swap ] ] if ;
85 : interpolate-attrs ( attrs -- quot )
87 [ [ interpolate-attr ] { } assoc>map [ ] join ]
89 '[ @ _ swap [ narray sift-values <attrs> ] dip ]
92 : interpolate-tag ( tag -- quot )
95 [ attrs>> interpolate-attrs ]
96 [ children>> interpolate-sequence ] tri
97 '[ _ swap @ @ [ <tag> ] dip ]
100 GENERIC: push-item ( item -- )
101 M: string push-item , ;
102 M: xml-data push-item , ;
103 M: object push-item present , ;
104 M: sequence push-item
105 dup xml-data? [ , ] [ [ push-item ] each ] if ;
107 [ before>> push-item ]
109 [ after>> push-item ] tri ;
110 M: number push-item present , ;
111 M: xml-chunk push-item % ;
113 : concat-interpolate ( array -- newarray )
114 [ [ push-item ] each ] { } make ;
116 GENERIC: interpolate-item ( item -- quot )
117 M: object interpolate-item [ swap ] curry ;
118 M: tag interpolate-item interpolate-tag ;
119 M: interpolated interpolate-item get-interpolated ;
121 : interpolate-sequence ( seq -- quot )
123 [ [ interpolate-item ] map concat ]
125 '[ @ _ swap [ narray concat-interpolate ] dip ]
126 ] when-interpolated ;
128 GENERIC: [interpolate-xml] ( xml -- quot )
130 M: xml [interpolate-xml]
131 dup body>> interpolate-tag
132 '[ _ (clone) swap @ drop >>body ] ;
134 M: xml-chunk [interpolate-xml]
136 '[ @ drop <xml-chunk> ] ;
138 MACRO: interpolate-xml ( xml -- quot )
141 : number<-> ( doc -- dup )
144 over >>var [ 1 + ] dip
146 ] each-interpolated drop ;
148 : >search-hash ( seq -- hash )
149 [ dup parse-word ] H{ } map>assoc ;
151 : extract-variables ( xml -- seq )
152 [ [ var>> , ] each-interpolated ] { } make ;
154 : nenum ( ... n -- assoc )
155 narray <enum> ; inline
157 : collect ( accum variables -- accum ? )
159 { [ dup empty? ] [ drop f ] } ! Just a literal
160 { [ dup [ ] all? ] [ >search-hash suffix! t ] } ! locals
161 { [ dup [ not ] all? ] [ length suffix! \ nenum suffix! t ] } ! fry
162 [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
165 : parse-def ( accum delimiter quot -- accum )
166 [ parse-multiline-string [ blank? ] trim ] dip call
167 [ extract-variables collect ] keep swap
168 [ number<-> suffix! ] dip
169 [ \ interpolate-xml suffix! ] when ; inline
174 "XML>" [ string>doc ] parse-def ;
177 "XML]" [ string>chunk ] parse-def ;
181 { "xml.syntax" "inverse" } "xml.syntax.inverse" require-when