1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs namespaces make kernel sequences accessors
4 combinators strings splitting io io.streams.string present
5 sets ascii xml.writer xml.data xml.entities html.forms
6 html.templates html.templates.chloe.syntax ;
7 IN: html.templates.chloe.compiler
9 : chloe-attrs-only ( assoc -- assoc' )
10 [ drop chloe-name? ] assoc-filter ;
12 : non-chloe-attrs-only ( assoc -- assoc' )
13 [ drop chloe-name? ] assoc-reject ;
15 : chloe-tag? ( tag -- ? )
16 dup xml? [ body>> ] when
18 { [ dup tag? not ] [ f ] }
19 { [ dup chloe-name? not ] [ f ] }
27 DEFER: compile-element
29 : compile-children ( tag -- )
30 [ compile-element ] each ;
32 : [write] ( string -- ) string-buffer get push-all ;
36 [ >string , \ write , ] [ delete-all ] bi
42 : [code-with] ( obj quot -- )
43 reset-buffer [ , ] [ % ] bi* ;
45 : [xml-code] ( quot -- )
46 [ write-xml ] compose [code] ;
48 : expand-attr ( value -- )
49 [ value present write ] [code-with] ;
51 : compile-attr ( value -- )
52 reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
54 : compile-attrs ( assoc -- )
57 swap name>string [write]
59 "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
63 : compile-self-closing-tag ( tag -- )
65 [ name>string [write] ] [ attrs>> compile-attrs ] bi
68 : compile-start-tag ( tag -- )
70 [ name>string [write] ] [ attrs>> compile-attrs ] bi
73 : compile-end-tag ( tag -- )
78 SYMBOL: string-context?
80 ERROR: tag-not-allowed-here ;
82 CONSTANT: self-closing-tags {
99 string-context? get [ tag-not-allowed-here ] when ;
101 : (compile-tag) ( tag -- )
102 dup name>string >lower self-closing-tags
104 compile-self-closing-tag
106 [ compile-start-tag ]
108 [ compile-end-tag ] tri
111 : compile-tag ( tag -- )
113 [ main>> tag-stack get push ]
117 ERROR: unknown-chloe-tag tag ;
119 : compile-chloe-tag ( tag -- )
120 dup main>> dup tags get at
122 [ unknown-chloe-tag ]
125 : compile-string ( string -- )
126 string-context? get [ escape-string ] unless [write] ;
128 : compile-misc ( object -- )
130 [ write-xml ] [code-with] ;
132 : compile-element ( element -- )
134 { [ dup chloe-tag? ] [ compile-chloe-tag ] }
135 { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
136 { [ dup string? ] [ compile-string ] }
137 { [ dup comment? ] [ drop ] }
141 : with-compiler ( quot -- quot' )
143 SBUF" " string-buffer set
144 V{ } clone tag-stack set
149 : compile-chunk ( seq -- )
150 [ compile-element ] each ;
152 : compile-quot ( quot -- )
155 SBUF" " string-buffer set
158 ] [ ] make , ; inline
160 : process-children ( tag quot -- )
161 [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
163 : compile-children>xml-string ( tag -- )
164 [ with-string-writer ] process-children ;
166 : compile-children>string ( tag -- )
168 compile-children>xml-string
171 : compile-with-scope ( quot -- )
172 compile-quot [ with-scope ] [code] ; inline
174 : if-not-nested ( quot -- )
175 nested-template? get swap unless ; inline
177 : compile-prologue ( xml -- )
179 [ prolog>> [ write-xml ] [code-with] ]
180 [ before>> compile-chunk ]
183 [ if-not-nested ] [code] ;
185 : compile-epilogue ( xml -- )
186 [ after>> compile-chunk ] compile-quot
187 [ if-not-nested ] [code] ;
189 : compile-template ( xml -- quot )