basis/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 splitting mirrors
   5 hashtables combinators continuations math strings inspector
   6 fry locals calendar calendar.format xml.entities
   7 validators urls present
   8 xmode.code2html lcs.diff2html farkup
   9 html.elements html.streams html.forms ;
  10 IN: html.components
  11
  12 GENERIC: render* ( value name render -- )
  13
  14 : render ( name renderer -- )
  15     prepare-value
  16     [
  17         dup validation-error?
  18         [ [ message>> ] [ value>> ] bi ]
  19         [ f swap ]
  20         if
  21     ] 2dip
  22     render*
  23     [ render-error ] when* ;
  24
  25 <PRIVATE
  26
  27 : render-input ( value name type -- )
  28     <input =type =name present =value input/> ;
  29
  30 PRIVATE>
  31
  32 SINGLETON: label
  33
  34 M: label render* 2drop present escape-string write ;
  35
  36 SINGLETON: hidden
  37
  38 M: hidden render* drop "hidden" render-input ;
  39
  40 : render-field ( value name size type -- )
  41     <input
  42         =type
  43         [ present =size ] when*
  44         =name
  45         present =value
  46     input/> ;
  47
  48 TUPLE: field size ;
  49
  50 : <field> ( -- field )
  51     field new ;
  52
  53 M: field render* size>> "text" render-field ;
  54
  55 TUPLE: password size ;
  56
  57 : <password> ( -- password )
  58     password new ;
  59
  60 M: password render*
  61     #! Don't send passwords back to the user
  62     [ drop "" ] 2dip size>> "password" render-field ;
  63
  64 ! Text areas
  65 TUPLE: textarea rows cols ;
  66
  67 : <textarea> ( -- renderer )
  68     textarea new ;
  69
  70 M: textarea render*
  71     <textarea
  72         [ rows>> [ present =rows ] when* ]
  73         [ cols>> [ present =cols ] when* ] bi
  74         =name
  75     textarea>
  76         present escape-string write
  77     </textarea> ;
  78
  79 ! Choice
  80 TUPLE: choice size multiple choices ;
  81
  82 : <choice> ( -- choice )
  83     choice new ;
  84
  85 : render-option ( text selected? -- )
  86     <option [ "true" =selected ] when option>
  87         present escape-string write
  88     </option> ;
  89
  90 : render-options ( options selected -- )
  91     '[ dup _ member? render-option ] each ;
  92
  93 M: choice render*
  94     <select
  95         swap =name
  96         dup size>> [ present =size ] when*
  97         dup multiple>> [ "true" =multiple ] when
  98     select>
  99         [ choices>> value ] [ multiple>> ] bi
 100         [ swap ] [ swap 1array ] if
 101         render-options
 102     </select> ;
 103
 104 ! Checkboxes
 105 TUPLE: checkbox label ;
 106
 107 : <checkbox> ( -- checkbox )
 108     checkbox new ;
 109
 110 M: checkbox render*
 111     <input
 112         "checkbox" =type
 113         swap =name
 114         swap [ "true" =checked ] when
 115     input>
 116         label>> escape-string write
 117     </input> ;
 118
 119 ! Link components
 120 GENERIC: link-title ( obj -- string )
 121 GENERIC: link-href ( obj -- url )
 122
 123 M: string link-title ;
 124 M: string link-href ;
 125
 126 M: url link-title ;
 127 M: url link-href ;
 128
 129 SINGLETON: link
 130
 131 M: link render*
 132     2drop
 133     <a dup link-href =href a>
 134         link-title present escape-string write
 135     </a> ;
 136
 137 ! XMode code component
 138 TUPLE: code mode ;
 139
 140 : <code> ( -- code )
 141     code new ;
 142
 143 M: code render*
 144     [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
 145
 146 ! Farkup component
 147 TUPLE: farkup no-follow disable-images ;
 148
 149 : string>boolean ( string -- boolean )
 150     {
 151         { "true" [ t ] }
 152         { "false" [ f ] }
 153     } case ;
 154
 155 M: farkup render*
 156     [
 157         [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
 158         [ disable-images>> [ string>boolean disable-images? set ] when* ] bi
 159         drop string-lines "\n" join write-farkup
 160     ] with-scope ;
 161
 162 ! Inspector component
 163 SINGLETON: inspector
 164
 165 M: inspector render*
 166     2drop [ describe ] with-html-stream ;
 167
 168 ! Diff component
 169 SINGLETON: comparison
 170
 171 M: comparison render*
 172     2drop htmlize-diff ;
 173
 174 ! HTML component
 175 SINGLETON: html
 176
 177 M: html render* 2drop write ;