Macros to emit [X][HT]ML

〈Overview〉 ≡

encoding: 'html-ascii
set-ml-encoding: func [new-encoding [word!]] [
 if find [html-ascii html-utf8] new-encoding [encoding: new-encoding]
]
tag-attribute: macro [
 name ;[any-word! any-path!]
 value
] [
 #" " either any [path? name set-path? name] [name/1 #":" name/2] [name] {="} either block? :value :value [text :value] #"^""
]
tag-attributes: macro/custom [
 name value
] [
 some [
  set name [set-word! | set-path!]
  do-next
  (if value: pop-result [emit output [tag-attribute name :value]])
  |
  set name [word! | path!]
  set value skip
  (if value [emit output [tag-attribute name :value]])
 ]
]
tag: macro [
 "Emit a tag"
 name
 attributes [block!]
 contents [word! block!] "'open, 'close, 'empty, or block with contents"
 /options
  custom-attributes [logic!]
] [
 #"<" if contents = 'close #"/" either path? name [name/1 #":" name/2] [name]
 either custom-attributes [emit attributes] [apply 'tag-attributes attributes]
 if contents = 'empty " /" #">"
 if block? contents [
  emit contents
  tag name [ ] 'close
 ]
]
text: macro [
 "Emit text"
 text
] [
 encode-text (form :text) encoding
]
cdata: macro [
 "Emit a CDATA section"
 contents [word! block!] "'open, 'close, or block with contents"
 /options
  commented "Use /* */ comments"
] [
 either block? contents [
  either commented [
   cdata/options 'open [commented: yes]
   emit contents
   cdata/options 'close [commented: yes]
  ] [
   cdata 'open
   emit contents
   cdata 'close
  ]
 ] [
  if commented ["^//* "]
  either contents = 'open [
   "<![CDATA["
  ] [
   "]]>"
  ]
  if commented [" */^/"]
 ]
]
style: macro [
 "Emit a <style> tag"
 attributes [block!]
 contents [none! block! string!]
] [
 tag 'style attributes switch type?/word contents [
  none! ['empty]
  block! [[emit contents]]
  string! [
   [cdata/options [(trim/auto copy contents)] [commented: yes]]
  ]
 ]
]

〈Overview〉 +≡

span?: func [layspec x y char /local x-span y-span tmp] [
 x-span: y-span: 1
 while [layspec/:y/(x + x-span) = char] [x-span: x-span + 1]
 while [all [tmp: layspec/(y + y-span) tmp/:x = char]] [y-span: y-span + 1]
 as-pair x-span y-span
]
make-table: func [spec /local layspec charmap word char style table width height row used] [
 charmap: copy [ ]
 layspec: copy [ ]
 parse spec [
  some [
   'repeat set word word! do-next (
    append/only layspec reduce [word make-table pop-result]
   )
   |
   set row string! (append layspec row)
  ]
  some [
   set word set-word! copy char some char! copy style any string! (
    foreach ch char [
     insert/only insert tail charmap ch reduce [word style]
    ]
   )
  ]
 ]
 height: length? layspec
 width: 0
 foreach str layspec [if string? str [width: max width length? str]]
 table: make block! 2 + height
 row: head insert/dup clear [ ] none width
 foreach r layspec [
  append/only table either string? r [copy row] [r]
 ]
 used: clear [ ]
 repeat y height [
  if string? layspec/:y [
   repeat x width [
    char: layspec/:y/:x
    unless find used char [
     append used char
     set [word style] select charmap char
     table/:y/:x: reduce [word span? layspec x y char style]
    ]
   ]
  ]
 ]
 table
]
cell-contents: 1 cell-span: 2 cell-style: 3
repeat-rows: macro [cells name table /local words block repeated-cells i: -1] [
 (
  parse cells [
   thru name 'foreach do-next do-next do-next (
    repeated-cells: pop-result
    block: pop-result
    words: pop-result
   )
   |
   (make error! "Invalid layout cells spec")
  ]
  []
 )
 foreach words block compose/only [
  make-rows table (repeated-cells) i: i + 1
 ]
]
make-rows: macro [
 table cells i
] [
 foreach 'row table [
  either word? row/1 [
   repeat-rows cells to set-word! row/1 row/2
  ] [
   tag 'tr [] [
    foreach 'cell row [
     if cell [
      tag 'td [
       colspan: cell/:cell-span/x
       rowspan: cell/:cell-span/y
       class: if cell/:cell-style [cell/:cell-style/(i // (length? cell/:cell-style) + 1)]
      ] any [select cells cell/:cell-contents []]
     ]
    ]
   ]
  ]
 ]
]
auto-size-col: context [
 stretch: shrink: min: width: none
]
layout: macro [
 "Layout using a HTML table"
 spec [block!]
 cells [block!]
 /local table table-style table-class auto-size as-group
] [
 (
  parse spec [
   any [
    'style set table-style string!
    |
    'class set table-class string!
    |
    'auto-size set as-group opt string! copy auto-size some block!
   ]
   spec:
  ]
  if auto-size [
   table-class: either table-class [
    append copy table-class " autosize"
   ] [
    "autosize"
   ]
  ]
  table: make-table spec
  [ ]
 )
 tag 'table [style: table-style class: table-class asGroup: as-group] [
  if block? auto-size [
   foreach 'item auto-size [
    (item: make auto-size-col item [ ])
    tag 'col [
     asStretch: item/stretch
     asShrink: item/shrink
     asMinWidth: item/min
     asWidth: item/width
    ] 'empty
   ]
  ]
  tag 'tbody [] [
   make-rows table cells 0
  ]
 ]
]