]> gitweb.factorcode.org Git - factor.git/blob - basis/html/templates/chloe/compiler/compiler.factor
Move call( and execute( to core
[factor.git] / basis / html / templates / chloe / compiler / compiler.factor
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 xml.writer xml.data xml.entities html.forms
6 html.templates html.templates.chloe.syntax ;
7 IN: html.templates.chloe.compiler
8
9 : chloe-attrs-only ( assoc -- assoc' )
10     [ drop chloe-name? ] assoc-filter ;
11
12 : non-chloe-attrs-only ( assoc -- assoc' )
13     [ drop chloe-name? not ] assoc-filter ;
14
15 : chloe-tag? ( tag -- ? )
16     dup xml? [ body>> ] when
17     {
18         { [ dup tag? not ] [ f ] }
19         { [ dup chloe-name? not ] [ f ] }
20         [ t ]
21     } cond nip ;
22
23 SYMBOL: string-buffer
24
25 SYMBOL: tag-stack
26
27 DEFER: compile-element
28
29 : compile-children ( tag -- )
30     [ compile-element ] each ;
31
32 : [write] ( string -- ) string-buffer get push-all ;
33
34 : reset-buffer ( -- )
35     string-buffer get [
36         [ >string , \ write , ] [ delete-all ] bi
37     ] unless-empty ;
38
39 : [code] ( quot -- )
40     reset-buffer % ;
41
42 : [code-with] ( obj quot -- )
43     reset-buffer [ , ] [ % ] bi* ;
44
45 : [xml-code] ( quot -- )
46     [ write-xml ] compose [code] ;
47
48 : expand-attr ( value -- )
49     [ value present write ] [code-with] ;
50
51 : compile-attr ( value -- )
52     reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
53
54 : compile-attrs ( assoc -- )
55     [
56         " " [write]
57         swap name>string [write]
58         "=\"" [write]
59         "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
60         "\"" [write]
61     ] assoc-each ;
62
63 : compile-start-tag ( tag -- )
64     "<" [write]
65     [ name>string [write] ] [ attrs>> compile-attrs ] bi
66     ">" [write] ;
67
68 : compile-end-tag ( tag -- )
69     "</" [write]
70     name>string [write]
71     ">" [write] ;
72
73 : compile-tag ( tag -- )
74     {
75         [ main>> tag-stack get push ]
76         [ compile-start-tag ]
77         [ compile-children ]
78         [ compile-end-tag ]
79     } cleave
80     tag-stack get pop* ;
81
82 ERROR: unknown-chloe-tag tag ;
83
84 : compile-chloe-tag ( tag -- )
85     dup main>> dup tags get at
86     [ call( tag -- ) ]
87     [ unknown-chloe-tag ]
88     ?if ;
89
90 : compile-element ( element -- )
91     {
92         { [ dup chloe-tag? ] [ compile-chloe-tag ] }
93         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
94         { [ dup string? ] [ escape-string [write] ] }
95         { [ dup comment? ] [ drop ] }
96         [ [ write-xml ] [code-with] ]
97     } cond ;
98
99 : with-compiler ( quot -- quot' )
100     [
101         SBUF" " string-buffer set
102         V{ } clone tag-stack set
103         call
104         reset-buffer
105     ] [ ] make ; inline
106
107 : compile-chunk ( seq -- )
108     [ compile-element ] each ;
109
110 : compile-quot ( quot -- )
111     reset-buffer
112     [
113         SBUF" " string-buffer set
114         call
115         reset-buffer
116     ] [ ] make , ; inline
117
118 : process-children ( tag quot -- )
119     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
120
121 : compile-children>string ( tag -- )
122     [ with-string-writer ] process-children ;
123
124 : compile-with-scope ( quot -- )
125     compile-quot [ with-scope ] [code] ; inline
126
127 : if-not-nested ( quot -- )
128     nested-template? get swap unless ; inline
129
130 : compile-prologue ( xml -- )
131     [
132         [ prolog>> [ write-xml ] [code-with] ]
133         [ before>> compile-chunk ]
134         bi
135     ] compile-quot
136     [ if-not-nested ] [code] ;
137
138 : compile-epilogue ( xml -- )
139     [ after>> compile-chunk ] compile-quot
140     [ if-not-nested ] [code] ;
141
142 : compile-template ( xml -- quot )
143     [
144         [ compile-prologue ]
145         [ compile-element ]
146         [ compile-epilogue ]
147         tri
148     ] with-compiler ;