basis/html/components/components.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators farkup html html.forms
   4 html.streams inspector io kernel lcs.diff2html namespaces
   5 present sequences splitting strings urls xml.data xml.syntax
   6 xml.writer xmode.code2html ;
   7 IN: html.components
   8
   9 GENERIC: render* ( value name renderer -- xml )
  10
  11 : render>xml ( name renderer -- xml )
  12     prepare-value
  13     [
  14         dup validation-error-state?
  15         [ [ message>> render-error ] [ value>> ] bi ]
  16         [ f swap ]
  17         if
  18     ] 2dip
  19     render*
  20     swap 2array ;
  21
  22 : render ( name renderer -- )
  23     render>xml write-xml ;
  24
  25 <PRIVATE
  26
  27 GENERIC: write-nested ( obj -- )
  28
  29 M: string write-nested write ;
  30
  31 M: sequence write-nested [ write-nested ] each ;
  32
  33 PRIVATE>
  34
  35 : render-string ( name renderer -- )
  36     render>xml write-nested ;
  37
  38 SINGLETON: label
  39
  40 M: label render*
  41     2drop present ;
  42
  43 SINGLETON: hidden
  44
  45 M: hidden render*
  46     drop [XML <input value=<-> name=<-> type="hidden"/> XML] ;
  47
  48 : render-field ( value name size type -- xml )
  49     [XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
  50
  51 TUPLE: field size ;
  52
  53 : <field> ( -- field )
  54     field new ;
  55
  56 M: field render*
  57     size>> "text" render-field ;
  58
  59 TUPLE: password size ;
  60
  61 : <password> ( -- password )
  62     password new ;
  63
  64 M: password render*
  65     ! Don't send passwords back to the user
  66     [ drop "" ] 2dip size>> "password" render-field ;
  67
  68 ! Text areas
  69 TUPLE: textarea rows cols ;
  70
  71 : <textarea> ( -- renderer )
  72     textarea new ;
  73
  74 M:: textarea render* ( value name area -- xml )
  75     area rows>> :> rows
  76     area cols>> :> cols
  77     [XML
  78          <textarea
  79             name=<-name->
  80             rows=<-rows->
  81             cols=<-cols->><-value-></textarea>
  82     XML] ;
  83
  84 ! Choice
  85 TUPLE: choice size multiple choices ;
  86
  87 : <choice> ( -- choice )
  88     choice new ;
  89
  90 : render-option ( text selected? -- xml )
  91     "selected" and swap
  92     [XML <option selected=<->><-></option> XML] ;
  93
  94 : render-options ( value choice -- xml )
  95     [ choices>> value ] [ multiple>> ] bi
  96     [ swap ] [ swap 1array ] if
  97     '[ dup _ member? render-option ] map ;
  98
  99 M:: choice render* ( value name choice -- xml )
 100     choice size>> :> size
 101     choice multiple>> "true" and :> multiple
 102     value choice render-options :> contents
 103     [XML <select
 104         name=<-name->
 105         size=<-size->
 106         multiple=<-multiple->><-contents-></select> XML] ;
 107
 108 ! Checkboxes
 109 TUPLE: checkbox label ;
 110
 111 : <checkbox> ( -- checkbox )
 112     checkbox new ;
 113
 114 M: checkbox render*
 115     [ "true" and ] [ ] [ label>> ] tri*
 116     [XML <input
 117         type="checkbox"
 118         checked=<-> name=<->><-></input> XML] ;
 119
 120 ! Link components
 121 GENERIC: link-title ( obj -- string )
 122 GENERIC: link-href ( obj -- url )
 123
 124 M: string link-title ;
 125 M: string link-href ;
 126
 127 M: url link-title ;
 128 M: url link-href ;
 129
 130 TUPLE: simple-link title href ;
 131
 132 C: <simple-link> simple-link
 133
 134 M: simple-link link-title title>> ;
 135 M: simple-link link-href href>> ;
 136
 137 TUPLE: link target ;
 138
 139 M: link render*
 140     nip swap
 141     [ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
 142     [XML <a target=<-> href=<->><-></a> XML] ;
 143
 144 ! XMode code component
 145 TUPLE: code mode ;
 146
 147 : <code> ( -- code )
 148     code new ;
 149
 150 : ?split-lines ( str/f -- seq )
 151     [ { } ] [ split-lines ] if-empty ;
 152
 153 M: code render*
 154     [ ?split-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 ;