1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators furnace.utilities
4 html.components html.forms html.templates
5 html.templates.chloe.compiler html.templates.chloe.syntax kernel
6 namespaces present sequences splitting urls xml.data xml.syntax
7 xml.traversal xml.writer ;
11 : parse-query-attr ( string -- assoc )
12 [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
14 : a-url-path ( href rest -- string )
16 [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
18 : a-url ( href rest query value-name -- url )
22 swap parse-query-attr >>query
23 -rot a-url-path >>path
27 : compile-a-url ( tag -- )
29 [ "href" optional-attr compile-attr ]
30 [ "rest" optional-attr compile-attr ]
31 [ "query" optional-attr compile-attr ]
32 [ "value" optional-attr compile-attr ]
33 } cleave [ a-url ] [code] ;
36 [ compile-children>xml-string ] [ compile-a-url ] bi
37 [ add-atom-feed ] [code] ;
39 CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
41 : compile-link-attrs ( tag -- )
42 ! Side-effects current namespace.
43 '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
45 : process-attrs ( assoc -- newassoc )
46 [ "@" ?head [ value present ] when ] assoc-map ;
48 : non-chloe-attrs ( tag -- )
49 attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
53 [ compile-link-attrs ]
55 [ present swap "href" swap [ set-at ] keep ] [code] ;
60 [ compile-children>xml-string ] bi
61 [ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
63 ] compile-with-scope ;
66 compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
68 : hidden-nested-fields ( -- xml )
69 nested-forms get join-words f like nested-forms-key
72 : render-hidden ( for -- xml )
73 [ "," split [ hidden render>xml ] map ] [ f ] if* ;
75 : compile-hidden-form-fields ( for -- )
80 [XML <div style="display: none;"><-><-><-></div> XML]
83 : (compile-form-attrs) ( method action -- )
84 ! Leaves an assoc on the stack at runtime
85 [ compile-attr [ "method" pick set-at ] [code] ]
86 [ compile-attr [ resolve-base-path "action" pick set-at ] [code] ]
89 : compile-method/action ( tag -- )
90 ! generated code is ( assoc -- assoc )
91 [ "method" optional-attr "post" or ]
92 [ "action" required-attr ] bi
93 (compile-form-attrs) ;
95 : compile-form-attrs ( tag -- )
97 [ compile-link-attrs ]
98 [ compile-method/action ] tri ;
100 : hidden-fields ( tag -- )
101 "for" optional-attr compile-hidden-form-fields ;
105 [ compile-form-attrs ]
107 [ compile-children>xml-string ] tri
109 <unescaped> [XML <form><-><-></form> XML] first
113 ] compile-with-scope ;
115 : button-tag-markup ( -- xml )
117 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
118 <div style="display: inline;"><button type="submit"></button></div>
122 : add-tag-attrs ( attrs tag -- )
123 attrs>> swap assoc-union! drop ;
128 [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
129 [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
130 [ [ children>> ] dip "button" deep-tag-named children<< ]
132 } 2cleave compile-chloe-tag ;