basis/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 present fry ;
   9
  10 IN: html.elements
  11
  12 SYMBOL: html
  13
  14 : write-html ( str -- )
  15     H{ { html t } } format ;
  16
  17 : print-html ( str -- )
  18     write-html "\n" write-html ;
  19
  20 <<
  21
  22 : elements-vocab ( -- vocab-name ) "html.elements" ;
  23
  24 : html-word ( name def effect -- )
  25     #! Define 'word creating' word to allow
  26     #! dynamically creating words.
  27     [ elements-vocab create ] 2dip define-declared ;
  28
  29 : <foo> ( str -- <str> ) "<" ">" surround ;
  30
  31 : def-for-html-word-<foo> ( name -- )
  32     #! Return the name and code for the <foo> patterned
  33     #! word.
  34     dup <foo> swap '[ _ <foo> write-html ]
  35     (( -- )) html-word ;
  36
  37 : <foo ( str -- <str ) "<" prepend ;
  38
  39 : def-for-html-word-<foo ( name -- )
  40     #! Return the name and code for the <foo patterned
  41     #! word.
  42     <foo dup '[ _ write-html ]
  43     (( -- )) html-word ;
  44
  45 : foo> ( str -- foo> ) ">" append ;
  46
  47 : def-for-html-word-foo> ( name -- )
  48     #! Return the name and code for the foo> patterned
  49     #! word.
  50     foo> [ ">" write-html ] (( -- )) html-word ;
  51
  52 : </foo> ( str -- </str> ) "</" ">" surround ;
  53
  54 : def-for-html-word-</foo> ( name -- )
  55     #! Return the name and code for the </foo> patterned
  56     #! word.
  57     </foo> dup '[ _ write-html ] (( -- )) html-word ;
  58
  59 : <foo/> ( str -- <str/> ) "<" "/>" surround ;
  60
  61 : def-for-html-word-<foo/> ( name -- )
  62     #! Return the name and code for the <foo/> patterned
  63     #! word.
  64     dup <foo/> swap '[ _ <foo/> write-html ]
  65     (( -- )) html-word ;
  66
  67 : foo/> ( str -- str/> ) "/>" append ;
  68
  69 : def-for-html-word-foo/> ( name -- )
  70     #! Return the name and code for the foo/> patterned
  71     #! word.
  72     foo/> [ "/>" write-html ] (( -- )) html-word ;
  73
  74 : define-closed-html-word ( name -- )
  75     #! Given an HTML tag name, define the words for
  76     #! that closable HTML tag.
  77     dup def-for-html-word-<foo>
  78     dup def-for-html-word-<foo
  79     dup def-for-html-word-foo>
  80     def-for-html-word-</foo> ;
  81
  82 : define-open-html-word ( name -- )
  83     #! Given an HTML tag name, define the words for
  84     #! that open HTML tag.
  85     dup def-for-html-word-<foo/>
  86     dup def-for-html-word-<foo
  87     def-for-html-word-foo/> ;
  88
  89 : write-attr ( value name -- )
  90     " " write-html
  91     write-html
  92     "='" write-html
  93     present escape-quoted-string write-html
  94     "'" write-html ;
  95
  96 : define-attribute-word ( name -- )
  97     dup "=" prepend swap
  98     '[ _ write-attr ] (( string -- )) html-word ;
  99
 100 ! Define some closed HTML tags
 101 [
 102     "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
 103     "ol" "li" "form" "a" "p" "html" "head" "body" "title"
 104     "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
 105     "script" "div" "span" "select" "option" "style" "input"
 106     "strong"
 107 ] [ define-closed-html-word ] each
 108
 109 ! Define some open HTML tags
 110 [
 111     "input"
 112     "br"
 113     "hr"
 114     "link"
 115     "img"
 116     "base"
 117 ] [ define-open-html-word ] each
 118
 119 ! Define some attributes
 120 [
 121     "method" "action" "type" "value" "name"
 122     "size" "href" "class" "border" "rows" "cols"
 123     "id" "onclick" "style" "valign" "accesskey"
 124     "src" "language" "colspan" "onchange" "rel"
 125     "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
 126     "media" "title" "multiple" "checked"
 127     "summary" "cellspacing" "align" "scope" "abbr"
 128     "nofollow" "alt" "target"
 129 ] [ define-attribute-word ] each
 130
 131 >>
 132
 133 : xhtml-preamble ( -- )
 134     "<?xml version=\"1.0\"?>" write-html
 135     "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
 136
 137 : simple-page ( title head-quot body-quot -- )
 138     #! Call the quotation, with all output going to the
 139     #! body of an html page with the given title.
 140     spin
 141     xhtml-preamble
 142     <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
 143         <head>
 144             <title> write </title>
 145             call
 146         </head>
 147         <body> call </body>
 148     </html> ; inline
 149
 150 : render-error ( message -- )
 151     <span "error" =class span> escape-string write </span> ;