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.utilities
  11 html.components
  12 html.elements
  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 furnace.utilities ;
  23 QUALIFIED-WITH: assocs a
  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 [ >r 3drop r> 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>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     attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
  60
  61 : a-start-tag ( tag -- )
  62     [ <a ] [code]
  63     [ non-chloe-attrs-only compile-attrs ]
  64     [ compile-link-attrs ]
  65     [ compile-a-url ]
  66     tri
  67     [ =href a> ] [code] ;
  68
  69 : a-end-tag ( tag -- )
  70     drop [ </a> ] [code] ;
  71
  72 CHLOE: a
  73     [
  74         [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
  75     ] compile-with-scope ;
  76
  77 CHLOE: base
  78     compile-a-url [ <base =href base/> ] [code] ;
  79
  80 : compile-hidden-form-fields ( for -- )
  81     '[
  82         <div "display: none;" =style div>
  83             _ [ "," split [ hidden render ] each ] when*
  84             nested-forms get " " join f like nested-forms-key hidden-form-field
  85             [ modify-form ] each-responder
  86         </div>
  87     ] [code] ;
  88
  89 : compile-form-attrs ( method action attrs -- )
  90     [ <form ] [code]
  91     [ compile-attr [ =method ] [code] ]
  92     [ compile-attr [ resolve-base-path =action ] [code] ]
  93     [ compile-attrs ]
  94     tri*
  95     [ form> ] [code] ;
  96
  97 : form-start-tag ( tag -- )
  98     [
  99         [ "method" optional-attr "post" or ]
 100         [ "action" required-attr ]
 101         [ attrs>> non-chloe-attrs-only ] tri
 102         compile-form-attrs
 103     ]
 104     [ "for" optional-attr compile-hidden-form-fields ] bi ;
 105
 106 : form-end-tag ( tag -- )
 107     drop [ </form> ] [code] ;
 108
 109 CHLOE: form
 110     [
 111         {
 112             [ compile-link-attrs ]
 113             [ form-start-tag ]
 114             [ compile-children ]
 115             [ form-end-tag ]
 116         } cleave
 117     ] compile-with-scope ;
 118
 119 STRING: button-tag-markup
 120 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
 121     <div style="display: inline;"><button type="submit"></button></div>
 122 </t:form>
 123 ;
 124
 125 : add-tag-attrs ( attrs tag -- )
 126     attrs>> swap update ;
 127
 128 CHLOE: button
 129     button-tag-markup string>xml body>>
 130     {
 131         [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
 132         [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
 133         [ [ children>> ] dip "button" deep-tag-named (>>children) ]
 134         [ nip ]
 135     } 2cleave compile-chloe-tag ;