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