extra/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.styles kernel present sequences words xml.entities ;
   4 IN: html.elements
   5
   6 SYMBOL: html
   7
   8 : write-html ( str -- )
   9     H{ { html t } } format ;
  10
  11 : print-html ( str -- )
  12     write-html "\n" write-html ;
  13
  14 <<
  15
  16 CONSTANT: elements-vocab "html.elements"
  17
  18 : html-word ( name def effect -- )
  19     ! Define 'word creating' word to allow
  20     ! dynamically creating words.
  21     [ elements-vocab create-word ] 2dip define-declared ;
  22
  23 : <foo> ( str -- <str> ) "<" ">" surround ;
  24
  25 : def-for-html-word-<foo> ( name -- )
  26     ! Return the name and code for the <foo> patterned
  27     ! word.
  28     dup <foo> swap '[ _ <foo> write-html ]
  29     ( -- ) html-word ;
  30
  31 : <foo ( str -- <str ) "<" prepend ;
  32
  33 : def-for-html-word-<foo ( name -- )
  34     ! Return the name and code for the <foo patterned
  35     ! word.
  36     <foo dup '[ _ write-html ]
  37     ( -- ) html-word ;
  38
  39 : foo> ( str -- foo> ) ">" append ;
  40
  41 : def-for-html-word-foo> ( name -- )
  42     ! Return the name and code for the foo> patterned
  43     ! word.
  44     foo> [ ">" write-html ] ( -- ) html-word ;
  45
  46 : </foo> ( str -- </str> ) "</" ">" surround ;
  47
  48 : def-for-html-word-</foo> ( name -- )
  49     ! Return the name and code for the </foo> patterned
  50     ! word.
  51     </foo> dup '[ _ write-html ] ( -- ) html-word ;
  52
  53 : <foo/> ( str -- <str/> ) "<" "/>" surround ;
  54
  55 : def-for-html-word-<foo/> ( name -- )
  56     ! Return the name and code for the <foo/> patterned
  57     ! word.
  58     dup <foo/> swap '[ _ <foo/> write-html ]
  59     ( -- ) html-word ;
  60
  61 : foo/> ( str -- str/> ) "/>" append ;
  62
  63 : def-for-html-word-foo/> ( name -- )
  64     ! Return the name and code for the foo/> patterned
  65     ! word.
  66     foo/> [ "/>" write-html ] ( -- ) html-word ;
  67
  68 : define-closed-html-word ( name -- )
  69     ! Given an HTML tag name, define the words for
  70     ! that closable HTML tag.
  71     dup def-for-html-word-<foo>
  72     dup def-for-html-word-<foo
  73     dup def-for-html-word-foo>
  74     def-for-html-word-</foo> ;
  75
  76 : define-open-html-word ( name -- )
  77     ! Given an HTML tag name, define the words for
  78     ! that open HTML tag.
  79     dup def-for-html-word-<foo/>
  80     dup def-for-html-word-<foo
  81     def-for-html-word-foo/> ;
  82
  83 : write-attr ( value name -- )
  84     " " write-html
  85     write-html
  86     "='" write-html
  87     present escape-quoted-string write-html
  88     "'" write-html ;
  89
  90 : define-attribute-word ( name -- )
  91     dup "=" prepend swap
  92     '[ _ write-attr ] ( string -- ) html-word ;
  93
  94 ! Define some closed HTML tags
  95 [
  96     "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
  97     "ol" "li" "form" "a" "p" "html" "head" "body" "title"
  98     "b" "i" "ul" "table" "thead" "tfoot" "tbody" "tr" "td" "th" "pre" "textarea"
  99     "script" "div" "span" "select" "option" "style" "input"
 100     "strong"
 101 ] [ define-closed-html-word ] each
 102
 103 ! Define some open HTML tags
 104 [
 105     "input"
 106     "br"
 107     "hr"
 108     "link"
 109     "img"
 110     "base"
 111 ] [ define-open-html-word ] each
 112
 113 ! Define some attributes
 114 [
 115     "method" "action" "type" "value" "name"
 116     "size" "href" "class" "border" "rows" "cols"
 117     "id" "onclick" "style" "valign" "accesskey"
 118     "src" "language" "colspan" "onchange" "rel"
 119     "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
 120     "media" "title" "multiple" "checked"
 121     "summary" "cellspacing" "align" "scope" "abbr"
 122     "nofollow" "alt" "target"
 123 ] [ define-attribute-word ] each
 124
 125 >>