basis/html/elements/elements.factor

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