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 assocs combinators fry 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 ;
   8 IN: furnace.chloe-tags
   9
  10 ! Chloe tags
  11 : parse-query-attr ( string -- assoc )
  12     [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
  13
  14 : a-url-path ( href rest -- string )
  15     dup [ value ] when
  16     [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
  17
  18 : a-url ( href rest query value-name -- url )
  19     dup [ 3nip value ] [
  20         drop
  21         <url>
  22             swap parse-query-attr >>query
  23             -rot a-url-path >>path
  24         adjust-url
  25     ] if ;
  26
  27 : compile-a-url ( tag -- )
  28     {
  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] ;
  34
  35 CHLOE: atom
  36     [ compile-children>xml-string ] [ compile-a-url ] bi
  37     [ add-atom-feed ] [code] ;
  38
  39 CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
  40
  41 : compile-link-attrs ( tag -- )
  42     ! Side-effects current namespace.
  43     '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
  44
  45 : process-attrs ( assoc -- newassoc )
  46     [ "@" ?head [ value present ] when ] assoc-map ;
  47
  48 : non-chloe-attrs ( tag -- )
  49     attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
  50
  51 : a-attrs ( tag -- )
  52     [ non-chloe-attrs ]
  53     [ compile-link-attrs ]
  54     [ compile-a-url ] tri
  55     [ present swap "href" swap [ set-at ] keep ] [code] ;
  56
  57 CHLOE: a
  58     [
  59         [ a-attrs ]
  60         [ compile-children>xml-string ] bi
  61         [ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
  62         [xml-code]
  63     ] compile-with-scope ;
  64
  65 CHLOE: base
  66     compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
  67
  68 : hidden-nested-fields ( -- xml )
  69     nested-forms get unwords f like nested-forms-key
  70     hidden-form-field ;
  71
  72 : render-hidden ( for -- xml )
  73     [ "," split [ hidden render>xml ] map ] [ f ] if* ;
  74
  75 : compile-hidden-form-fields ( for -- )
  76     '[
  77         _ render-hidden
  78         hidden-nested-fields
  79         form-modifications
  80         [XML <div style="display: none;"><-><-><-></div> XML]
  81     ] [code] ;
  82
  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] ]
  87     bi* ;
  88
  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) ;
  94
  95 : compile-form-attrs ( tag -- )
  96     [ non-chloe-attrs ]
  97     [ compile-link-attrs ]
  98     [ compile-method/action ] tri ;
  99
 100 : hidden-fields ( tag -- )
 101     "for" optional-attr compile-hidden-form-fields ;
 102
 103 CHLOE: form
 104     [
 105         [ compile-form-attrs ]
 106         [ hidden-fields ]
 107         [ compile-children>xml-string ] tri
 108         [
 109             <unescaped> [XML <form><-><-></form> XML] second
 110                 swap >>attrs
 111             write-xml
 112         ] [code]
 113     ] compile-with-scope ;
 114
 115 : button-tag-markup ( -- xml )
 116     <XML
 117         <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
 118             <div style="display: inline;"><button type="submit"></button></div>
 119         </t:form>
 120     XML> body>> clone ;
 121
 122 : add-tag-attrs ( attrs tag -- )
 123     attrs>> swap assoc-union! drop ;
 124
 125 CHLOE: button
 126     button-tag-markup
 127     {
 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<< ]
 131         [ nip ]
 132     } 2cleave compile-chloe-tag ;