extra/html/components/components.factor

   1 ! Copyright (C) 2008 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel namespaces io math.parser assocs classes
   4 classes.tuple words arrays sequences sequences.lib splitting
   5 mirrors hashtables combinators continuations math strings
   6 fry locals calendar calendar.format xml.entities validators
   7 html.elements html.streams xmode.code2html farkup inspector
   8 lcs.diff2html urls present ;
   9 IN: html.components
  10
  11 SYMBOL: values
  12
  13 : value ( name -- value ) values get at ;
  14
  15 : set-value ( value name -- ) values get set-at ;
  16
  17 : blank-values ( -- ) H{ } clone values set ;
  18
  19 : prepare-value ( name object -- value name object )
  20     [ [ value ] keep ] dip ; inline
  21
  22 : from-object ( object -- )
  23     dup assoc? [ <mirror> ] unless
  24     values get swap update ;
  25
  26 : deposit-values ( destination names -- )
  27     [ dup value ] H{ } map>assoc update ;
  28
  29 : deposit-slots ( destination names -- )
  30     [ <mirror> ] dip deposit-values ;
  31
  32 : with-each-value ( name quot -- )
  33     [ value ] dip '[
  34         [
  35             values [ clone ] change
  36             1+ "index" set-value
  37             "value" set-value
  38             @
  39         ] with-scope
  40     ] each-index ; inline
  41
  42 : with-each-object ( name quot -- )
  43     [ value ] dip '[
  44         [
  45             blank-values
  46             1+ "index" set-value
  47             from-object
  48             @
  49         ] with-scope
  50     ] each-index ; inline
  51
  52 SYMBOL: nested-values
  53
  54 : with-values ( name quot -- )
  55     '[
  56         ,
  57         [ nested-values [ swap prefix ] change ]
  58         [ value blank-values from-object ]
  59         bi
  60         @
  61     ] with-scope ; inline
  62
  63 : nest-values ( name quot -- )
  64     swap [
  65         [
  66             H{ } clone [ values set call ] keep
  67         ] with-scope
  68     ] dip set-value ; inline
  69
  70 GENERIC: render* ( value name render -- )
  71
  72 : render ( name renderer -- )
  73     over named-validation-messages get at [
  74         [ value>> ] [ message>> ] bi
  75         [ -rot render* ] dip
  76         render-error
  77     ] [
  78         prepare-value render*
  79     ] if* ;
  80
  81 <PRIVATE
  82
  83 : render-input ( value name type -- )
  84     <input =type =name present =value input/> ;
  85
  86 PRIVATE>
  87
  88 SINGLETON: label
  89
  90 M: label render* 2drop present escape-string write ;
  91
  92 SINGLETON: hidden
  93
  94 M: hidden render* drop "hidden" render-input ;
  95
  96 : render-field ( value name size type -- )
  97     <input
  98         =type
  99         [ present =size ] when*
 100         =name
 101         present =value
 102     input/> ;
 103
 104 TUPLE: field size ;
 105
 106 : <field> ( -- field )
 107     field new ;
 108
 109 M: field render* size>> "text" render-field ;
 110
 111 TUPLE: password size ;
 112
 113 : <password> ( -- password )
 114     password new ;
 115
 116 M: password render*
 117     #! Don't send passwords back to the user
 118     [ drop "" ] 2dip size>> "password" render-field ;
 119
 120 ! Text areas
 121 TUPLE: textarea rows cols ;
 122
 123 : <textarea> ( -- renderer )
 124     textarea new ;
 125
 126 M: textarea render*
 127     <textarea
 128         [ rows>> [ present =rows ] when* ]
 129         [ cols>> [ present =cols ] when* ] bi
 130         =name
 131     textarea>
 132         present escape-string write
 133     </textarea> ;
 134
 135 ! Choice
 136 TUPLE: choice size multiple choices ;
 137
 138 : <choice> ( -- choice )
 139     choice new ;
 140
 141 : render-option ( text selected? -- )
 142     <option [ "true" =selected ] when option>
 143         present escape-string write
 144     </option> ;
 145
 146 : render-options ( options selected -- )
 147     '[ dup , member? render-option ] each ;
 148
 149 M: choice render*
 150     <select
 151         swap =name
 152         dup size>> [ present =size ] when*
 153         dup multiple>> [ "true" =multiple ] when
 154     select>
 155         [ choices>> value ] [ multiple>> ] bi
 156         [ swap ] [ swap 1array ] if
 157         render-options
 158     </select> ;
 159
 160 ! Checkboxes
 161 TUPLE: checkbox label ;
 162
 163 : <checkbox> ( -- checkbox )
 164     checkbox new ;
 165
 166 M: checkbox render*
 167     <input
 168         "checkbox" =type
 169         swap =name
 170         swap [ "true" =checked ] when
 171     input>
 172         label>> escape-string write
 173     </input> ;
 174
 175 ! Link components
 176 GENERIC: link-title ( obj -- string )
 177 GENERIC: link-href ( obj -- url )
 178
 179 M: string link-title ;
 180 M: string link-href ;
 181
 182 M: url link-title ;
 183 M: url link-href ;
 184
 185 SINGLETON: link
 186
 187 M: link render*
 188     2drop
 189     <a dup link-href =href a>
 190         link-title present escape-string write
 191     </a> ;
 192
 193 ! XMode code component
 194 TUPLE: code mode ;
 195
 196 : <code> ( -- code )
 197     code new ;
 198
 199 M: code render*
 200     [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
 201
 202 ! Farkup component
 203 SINGLETON: farkup
 204
 205 M: farkup render*
 206     2drop string-lines "\n" join convert-farkup write ;
 207
 208 ! Inspector component
 209 SINGLETON: inspector
 210
 211 M: inspector render*
 212     2drop [ describe ] with-html-stream ;
 213
 214 ! Diff component
 215 SINGLETON: comparison
 216
 217 M: comparison render*
 218     2drop htmlize-diff ;
 219
 220 ! HTML component
 221 SINGLETON: html
 222
 223 M: html render* 2drop write ;