extra/html/elements/elements.factor

   1 ! cont-html v0.6
   2 !
   3 ! Copyright (C) 2004 Chris Double.
   4 ! See http://factorcode.org/license.txt for BSD license.
   5
   6 USING: io kernel namespaces prettyprint quotations
   7 sequences strings words xml.entities compiler.units effects
   8 urls math math.parser combinators calendar calendar.format ;
   9
  10 IN: html.elements
  11
  12 ! These words are used to provide a means of writing
  13 ! formatted HTML to standard output with a familiar 'html' look
  14 ! and feel in the code.
  15 !
  16 ! HTML tags can be used in a number of different ways. The highest
  17 ! level involves a similar syntax to HTML:
  18 !
  19 ! <p> "someoutput" write </p>
  20 !
  21 ! <p> will output the opening tag and </p> will output the closing
  22 ! tag with no attributes.
  23 !
  24 ! <p "red" =class p> "someoutput" write </p>
  25 !
  26 ! This time the opening tag does not have the '>'. It pushes
  27 ! a namespace on the stack to hold the attributes and values.
  28 ! Any attribute words used will store the attribute and values
  29 ! in that namespace. Before the attribute word should come the
  30 ! value of that attribute.
  31 ! The finishing word will print out the operning tag including
  32 ! attributes.
  33 ! Any writes after this will appear after the opening tag.
  34 !
  35 ! Values for attributes can be used directly without any stack
  36 ! operations:
  37 !
  38 ! (url -- )
  39 ! <a =href a> "Click me" write </a>
  40 !
  41 ! (url -- )
  42 ! <a "http://" prepend =href a> "click" write </a>
  43 !
  44 ! (url -- )
  45 ! <a [ "http://" % % ] "" make =href a> "click" write </a>
  46 !
  47 ! Tags that have no 'closing' equivalent have a trailing tag/> form:
  48 !
  49 ! <input "text" =type "name" =name "20" =size input/>
  50
  51 : elements-vocab ( -- vocab-name ) "html.elements" ;
  52
  53 SYMBOL: html
  54
  55 : write-html ( str -- )
  56     H{ { html t } } format ;
  57
  58 : print-html ( str -- )
  59     write-html "\n" write-html ;
  60
  61 <<
  62
  63 : html-word ( name def effect -- )
  64     #! Define 'word creating' word to allow
  65     #! dynamically creating words.
  66     >r >r elements-vocab create r> r> define-declared ;
  67
  68 : <foo> "<" swap ">" 3append ;
  69
  70 : empty-effect T{ effect f 0 0 } ;
  71
  72 : def-for-html-word-<foo> ( name -- )
  73     #! Return the name and code for the <foo> patterned
  74     #! word.
  75     dup <foo> swap [ <foo> write-html ] curry
  76     empty-effect html-word ;
  77
  78 : <foo "<" prepend ;
  79
  80 : def-for-html-word-<foo ( name -- )
  81     #! Return the name and code for the <foo patterned
  82     #! word.
  83     <foo dup [ write-html ] curry
  84     empty-effect html-word ;
  85
  86 : foo> ">" append ;
  87
  88 : def-for-html-word-foo> ( name -- )
  89     #! Return the name and code for the foo> patterned
  90     #! word.
  91     foo> [ ">" write-html ] empty-effect html-word ;
  92
  93 : </foo> "</" swap ">" 3append ;
  94
  95 : def-for-html-word-</foo> ( name -- )
  96     #! Return the name and code for the </foo> patterned
  97     #! word.
  98     </foo> dup [ write-html ] curry empty-effect html-word ;
  99
 100 : <foo/> "<" swap "/>" 3append ;
 101
 102 : def-for-html-word-<foo/> ( name -- )
 103     #! Return the name and code for the <foo/> patterned
 104     #! word.
 105     dup <foo/> swap [ <foo/> write-html ] curry
 106     empty-effect html-word ;
 107
 108 : foo/> "/>" append ;
 109
 110 : def-for-html-word-foo/> ( name -- )
 111     #! Return the name and code for the foo/> patterned
 112     #! word.
 113     foo/> [ "/>" write-html ] empty-effect html-word ;
 114
 115 : define-closed-html-word ( name -- )
 116     #! Given an HTML tag name, define the words for
 117     #! that closable HTML tag.
 118     dup def-for-html-word-<foo>
 119     dup def-for-html-word-<foo
 120     dup def-for-html-word-foo>
 121     def-for-html-word-</foo> ;
 122
 123 : define-open-html-word ( name -- )
 124     #! Given an HTML tag name, define the words for
 125     #! that open HTML tag.
 126     dup def-for-html-word-<foo/>
 127     dup def-for-html-word-<foo
 128     def-for-html-word-foo/> ;
 129
 130 : object>string ( object -- string )
 131     #! Should this be generic and in the core?
 132     {
 133         { [ dup real? ] [ number>string ] }
 134         { [ dup timestamp? ] [ timestamp>string ] }
 135         { [ dup url? ] [ url>string ] }
 136         { [ dup string? ] [ ] }
 137         { [ dup word? ] [ word-name ] }
 138         { [ dup not ] [ drop "" ] }
 139     } cond ;
 140
 141 : write-attr ( value name -- )
 142     " " write-html
 143     write-html
 144     "='" write-html
 145     object>string escape-quoted-string write-html
 146     "'" write-html ;
 147
 148 : attribute-effect T{ effect f { "string" } 0 } ;
 149
 150 : define-attribute-word ( name -- )
 151     dup "=" prepend swap
 152     [ write-attr ] curry attribute-effect html-word ;
 153
 154 ! Define some closed HTML tags
 155 [
 156     "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
 157     "ol" "li" "form" "a" "p" "html" "head" "body" "title"
 158     "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
 159     "script" "div" "span" "select" "option" "style" "input"
 160 ] [ define-closed-html-word ] each
 161
 162 ! Define some open HTML tags
 163 [
 164     "input"
 165     "br"
 166     "link"
 167     "img"
 168 ] [ define-open-html-word ] each
 169
 170 ! Define some attributes
 171 [
 172     "method" "action" "type" "value" "name"
 173     "size" "href" "class" "border" "rows" "cols"
 174     "id" "onclick" "style" "valign" "accesskey"
 175     "src" "language" "colspan" "onchange" "rel"
 176     "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
 177     "media" "title" "multiple" "checked"
 178 ] [ define-attribute-word ] each
 179
 180 >>
 181
 182 : xhtml-preamble ( -- )
 183     "<?xml version=\"1.0\"?>" write-html
 184     "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
 185
 186 : simple-page ( title quot -- )
 187     #! Call the quotation, with all output going to the
 188     #! body of an html page with the given title.
 189     xhtml-preamble
 190     <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
 191         <head> <title> swap write </title> </head>
 192         <body> call </body>
 193     </html> ; inline
 194
 195 : render-error ( message -- )
 196     <span "error" =class span> escape-string write </span> ;