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