1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: words assocs kernel accessors parser sequences summary
4 lexer splitting combinators locals xml.data memoize sequences.deep
5 xml.data xml.state xml namespaces present arrays generalizations strings
6 make math macros multiline inverse combinators.short-circuit
7 sorting fry unicode.categories ;
12 TUPLE: no-tag name word ;
14 drop "The tag-dispatching word has no method for the given tag name" ;
16 : compile-tags ( word xtable -- quot )
17 >alist swap '[ _ no-tag boa throw ] suffix
18 '[ dup main>> _ case ] ;
20 : define-tags ( word -- )
21 dup dup "xtable" word-prop compile-tags define ;
23 :: define-tag ( string word quot -- )
24 quot string word "xtable" word-prop set-at
31 [ H{ } clone "xtable" set-word-prop ]
32 [ define-tags ] bi ; parsing
35 scan scan-word parse-definition define-tag ; parsing
38 CREATE-WORD (( string -- name )) over set-stack-effect
39 scan '[ f swap _ <name> ] define-memoized ; parsing
43 : each-attrs ( attrs quot -- )
44 [ values [ interpolated? ] filter ] dip each ; inline
46 : (each-interpolated) ( item quot: ( interpolated -- ) -- )
48 { [ over interpolated? ] [ call ] }
49 { [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
50 { [ over attrs? ] [ each-attrs ] }
51 { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
53 } cond ; inline recursive
55 : each-interpolated ( xml quot -- )
56 '[ _ (each-interpolated) ] deep-each ; inline
58 : has-interpolated? ( xml -- ? )
59 ! If this becomes a performance problem, it can be improved
60 f swap [ 2drop t ] each-interpolated ;
62 : when-interpolated ( xml quot -- genquot )
63 [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
65 : string>chunk ( string -- chunk )
66 t interpolating? [ string>xml-chunk ] with-variable ;
68 : string>doc ( string -- xml )
69 t interpolating? [ string>xml ] with-variable ;
71 DEFER: interpolate-sequence
73 : get-interpolated ( interpolated -- quot )
74 var>> '[ [ _ swap at ] keep ] ;
76 : ?present ( object -- string )
77 dup [ present ] when ;
79 : interpolate-attr ( key value -- quot )
81 [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
82 [ 2array '[ _ swap ] ] if ;
84 : filter-nulls ( assoc -- newassoc )
85 [ nip ] assoc-filter ;
87 : interpolate-attrs ( attrs -- quot )
89 [ [ interpolate-attr ] { } assoc>map [ ] join ]
91 '[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
94 : interpolate-tag ( tag -- quot )
97 [ attrs>> interpolate-attrs ]
98 [ children>> interpolate-sequence ] tri
99 '[ _ swap @ @ [ <tag> ] dip ]
100 ] when-interpolated ;
102 GENERIC: push-item ( item -- )
103 M: string push-item , ;
104 M: xml-data push-item , ;
105 M: object push-item present , ;
106 M: sequence push-item
107 dup xml-data? [ , ] [ [ push-item ] each ] if ;
108 M: number push-item present , ;
109 M: xml-chunk push-item % ;
111 : concat-interpolate ( array -- newarray )
112 [ [ push-item ] each ] { } make ;
114 GENERIC: interpolate-item ( item -- quot )
115 M: object interpolate-item [ swap ] curry ;
116 M: tag interpolate-item interpolate-tag ;
117 M: interpolated interpolate-item get-interpolated ;
119 : interpolate-sequence ( seq -- quot )
121 [ [ interpolate-item ] map concat ]
123 '[ @ _ swap [ narray concat-interpolate ] dip ]
124 ] when-interpolated ;
126 GENERIC: [interpolate-xml] ( xml -- quot )
128 M: xml [interpolate-xml]
129 dup body>> interpolate-tag
130 '[ _ (clone) swap @ drop >>body ] ;
132 M: xml-chunk [interpolate-xml]
134 '[ @ drop <xml-chunk> ] ;
136 MACRO: interpolate-xml ( xml -- quot )
139 : number<-> ( doc -- dup )
142 over >>var [ 1+ ] dip
144 ] each-interpolated drop ;
146 : >search-hash ( seq -- hash )
147 [ dup search ] H{ } map>assoc ;
149 : extract-variables ( xml -- seq )
150 [ [ var>> , ] each-interpolated ] { } make ;
152 : nenum ( ... n -- assoc )
153 narray <enum> ; inline
155 : collect ( accum variables -- accum ? )
157 { [ dup empty? ] [ drop f ] } ! Just a literal
158 { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
159 { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
160 [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
163 : parse-def ( accum delimiter quot -- accum )
164 [ parse-multiline-string [ blank? ] trim ] dip call
165 [ extract-variables collect ] keep swap
166 [ number<-> parsed ] dip
167 [ \ interpolate-xml parsed ] when ; inline
172 "XML>" [ string>doc ] parse-def ; parsing
175 "XML]" [ string>chunk ] parse-def ; parsing
177 : remove-blanks ( seq -- newseq )
178 [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
180 GENERIC: >xml ( xml -- tag )
186 [ first dup tag? [ fail ] unless ] bi ;
187 M: object >xml fail ;
189 : 1chunk ( object -- xml-chunk )
192 GENERIC: >xml-chunk ( xml -- chunk )
193 M: xml >xml-chunk body>> 1chunk ;
194 M: xml-chunk >xml-chunk ;
195 M: object >xml-chunk 1chunk ;
197 GENERIC: [undo-xml] ( xml -- quot )
200 body>> [undo-xml] '[ >xml @ ] ;
202 M: xml-chunk [undo-xml]
203 seq>> [undo-xml] '[ >xml-chunk @ ] ;
205 : undo-attrs ( attrs -- quot: ( attrs -- ) )
207 [ main>> ] dip dup interpolated?
208 [ var>> '[ _ attr _ set ] ]
209 [ '[ _ attr _ =/fail ] ] if
210 ] { } assoc>map '[ _ cleave ] ;
212 M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
214 [ name>> main>> '[ name>> main>> _ =/fail ] ]
215 [ attrs>> undo-attrs ]
216 [ children>> [undo-xml] '[ children>> @ ] ]
217 } cleave '[ _ _ _ tri ] ;
219 : firstn-strong ( seq n -- ... )
220 [ swap length =/fail ]
221 [ firstn ] 2bi ; inline
223 M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
224 remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
225 '[ remove-blanks _ firstn-strong _ spread ] ;
227 M: string [undo-xml] ( string -- quot: ( string -- ) )
230 M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
233 M: interpolated [undo-xml]
236 : >enum ( assoc -- enum )
237 ! Assumes keys are 0..n
238 >alist sort-keys values <enum> ;
240 : undo-xml ( xml -- quot )
241 [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
243 \ interpolate-xml 1 [ undo-xml ] define-pop-inverse