basis/furnace/chloe-tags/chloe-tags.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel combinators assocs
   4 namespaces sequences splitting words
   5 fry urls multiline present
   6 xml
   7 xml.data
   8 xml.entities
   9 xml.writer
  10 xml.traversal
  11 xml.syntax
  12 html.components
  13 html.forms
  14 html.templates
  15 html.templates.chloe
  16 html.templates.chloe.compiler
  17 html.templates.chloe.syntax
  18 http
  19 http.server
  20 http.server.redirection
  21 http.server.responses
  22 io.streams.string
  23 furnace.utilities ;
  24 IN: furnace.chloe-tags
  25
  26 ! Chloe tags
  27 : parse-query-attr ( string -- assoc )
  28     [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
  29
  30 : a-url-path ( href rest -- string )
  31     dup [ value ] when
  32     [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
  33
  34 : a-url ( href rest query value-name -- url )
  35     dup [ [ 3drop ] dip value ] [
  36         drop
  37         <url>
  38             swap parse-query-attr >>query
  39             -rot a-url-path >>path
  40         adjust-url
  41     ] if ;
  42
  43 : compile-a-url ( tag -- )
  44     {
  45         [ "href" optional-attr compile-attr ]
  46         [ "rest" optional-attr compile-attr ]
  47         [ "query" optional-attr compile-attr ]
  48         [ "value" optional-attr compile-attr ]
  49     } cleave [ a-url ] [code] ;
  50
  51 CHLOE: atom
  52     [ compile-children>xml-string ] [ compile-a-url ] bi
  53     [ add-atom-feed ] [code] ;
  54
  55 CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
  56
  57 : compile-link-attrs ( tag -- )
  58     ! Side-effects current namespace.
  59     '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
  60
  61 : process-attrs ( assoc -- newassoc )
  62     [ "@" ?head [ value present ] when ] assoc-map ;
  63
  64 : non-chloe-attrs ( tag -- )
  65     attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
  66
  67 : a-attrs ( tag -- )
  68     [ non-chloe-attrs ]
  69     [ compile-link-attrs ]
  70     [ compile-a-url ] tri
  71     [ present swap "href" swap [ set-at ] keep ] [code] ;
  72
  73 CHLOE: a
  74     [
  75         [ a-attrs ]
  76         [ compile-children>xml-string ] bi
  77         [ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
  78         [xml-code]
  79     ] compile-with-scope ;
  80
  81 CHLOE: base
  82     compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
  83
  84 : hidden-nested-fields ( -- xml )
  85     nested-forms get " " join f like nested-forms-key
  86     hidden-form-field ;
  87
  88 : render-hidden ( for -- xml )
  89     [ "," split [ hidden render>xml ] map ] [ f ] if* ;
  90
  91 : compile-hidden-form-fields ( for -- )
  92     '[
  93         _ render-hidden
  94         hidden-nested-fields
  95         form-modifications
  96         [XML <div style="display: none;"><-><-><-></div> XML]
  97     ] [code] ;
  98
  99 : (compile-form-attrs) ( method action -- )
 100     ! Leaves an assoc on the stack at runtime
 101     [ compile-attr [ "method" pick set-at ] [code] ]
 102     [ compile-attr [ resolve-base-path "action" pick set-at ] [code] ]
 103     bi* ;
 104
 105 : compile-method/action ( tag -- )
 106     ! generated code is ( assoc -- assoc )
 107     [ "method" optional-attr "post" or ]
 108     [ "action" required-attr ] bi
 109     (compile-form-attrs) ;
 110
 111 : compile-form-attrs ( tag -- )
 112     [ non-chloe-attrs ]
 113     [ compile-link-attrs ]
 114     [ compile-method/action ] tri ;
 115
 116 : hidden-fields ( tag -- )
 117     "for" optional-attr compile-hidden-form-fields ;
 118
 119 CHLOE: form
 120     [
 121         [ compile-form-attrs ]
 122         [ hidden-fields ]
 123         [ compile-children>xml-string ] tri
 124         [
 125             <unescaped> [XML <form><-><-></form> XML] second
 126                 swap >>attrs
 127             write-xml
 128         ] [code]
 129     ] compile-with-scope ;
 130
 131 : button-tag-markup ( -- xml )
 132     <XML
 133         <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
 134             <div style="display: inline;"><button type="submit"></button></div>
 135         </t:form>
 136     XML> body>> clone ;
 137
 138 : add-tag-attrs ( attrs tag -- )
 139     attrs>> swap assoc-union! drop ;
 140
 141 CHLOE: button
 142     button-tag-markup
 143     {
 144         [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
 145         [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
 146         [ [ children>> ] dip "button" deep-tag-named children<< ]
 147         [ nip ]
 148     } 2cleave compile-chloe-tag ;