basis/html/components/components.factor

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