Posted to tcl by smlckz at Sat Nov 29 05:35:56 GMT 2025view pretty

## ==== htmlgen.tcl ====
package require Tcl 8.6

# Taken from https://wiki.tcl-lang.org/page/Config+file+using+slave+interp
proc parse {body} {
  set i [interp create -safe]
  try {
    $i eval {namespace delete ::}
    $i alias unknown apply {args {
      upvar 1 a a
      lappend a $args
      return
    }}
    set a {}
    $i eval $body
    return $a
  } finally {
    interp delete $i
  }
}

proc html_escape {text} {
  return [string map {& &amp; < &lt; > &gt; {"} &quot;} $text]
}

proc tag {args} {
  set break_lines 0
  set recurse 0
  set self_closing 0
  set open_only 0
  set xml 0
  set i 0
  set n [llength $args]
  while {$i < $n} {
    set arg [lindex $args $i]
    switch -exact -- $arg {
      -breaklines {set break_lines 1}
      -recurse {set recurse 1}
      -selfclosing {set self_closing 1}
      -openonly {set open_only 1}
      -xml {set xml 1}
      -- {incr i; break}
      default break
    }
    incr i
  }
  set name [lindex $args $i]
  set result "<$name"
  incr i
  while {$i < $n} {
    set key [lindex $args $i]
    if {![string equal -length 1 $key -]} break
    if {[string equal $key --]} {incr i; break}
    if {[string equal [string index $key 1] ?]} {
      append result { } [string range $key 2 end]
      incr i
    } else {
      append result { } [string range $key 1 end] {="} [html_escape [lindex $args $i+1]] {"}
      incr i 2
    }
  }
  if {$self_closing && $xml} {append result {/}}
  append result {>}
  if {$self_closing || $open_only} {return $result}
  set children [lrange $args $i end]
  if $recurse {
    set children [lmap child $children {process $child $break_lines}]
  }
  if $break_lines {
    append result "\n  " [string map {\n "\n  "} [join $children \n]] "\n"
  } else {
    append result [join $children]
  }
  append result "</$name>"
}

set h [interp create -safe]
$h alias unknown tag --
$h alias escape html_escape
foreach {alias name} {` code // em ** strong % h1 %% h2} {
  $h alias $alias tag $name
}

foreach {flags names} {
  {-breaklines -recurse} {ul}
  -selfclosing {meta}
  -openonly {html}
} {
  foreach name $names {
    $h alias $name tag {*}$flags -- $name
  }
}

foreach {name params f} {
  comment body {return "<!--[escape $body]-->"}
  doctype args {return "<!doctype [join $args]>"}
} {
  $h eval [list proc $name $params $f]
}

proc process {body {multiline 0}} {
  set result [lmap tree [parse $body] {$::h eval $tree}]
  if $multiline {join $result \n} else {join $result}
}

if {$argc < 1} {
  puts "usage: tclsh $argv0 filename"
  return
}

set f [open [lindex $argv 0]]
set body [read $f]
close $f
puts [process [$h eval [list subst $body]] 1]

## ==== sample input ====
% [` smlckz]s website

p Hello, Im [` smlckz]. I like studying. I am interested in mathematics, programming and philosophy.

%% Contact

ul -class contact {
  li Mastodon: [a -rel me -href {https://c.im/@smlckz} @smlckz@c.im]
  li IRC: [` smlckz] on [a -href {https://tilde.chat} tilde.chat] and [a -href {https://libera.chat} libera.chat]
}

comment {
  SPDX-FileCopyrightText: 2025 smlckz
  SPDX-License-Identifier: CC-BY-SA-4.0
}
## ==== sample output ====
<h1><code>smlckz</code>s website</h1>
<p>Hello, Im <code>smlckz</code>. I like studying. I am interested in mathematics, programming and philosophy.</p>
<h2>Contact</h2>
<ul class="contact">
  <li>Mastodon: <a rel="me" href="https://c.im/@smlckz">@smlckz@c.im</a></li>
  <li>IRC: <code>smlckz</code> on <a href="https://tilde.chat">tilde.chat</a> and <a href="https://libera.chat">libera.chat</a></li>
</ul>
<!--
  SPDX-FileCopyrightText: 2025 smlckz
  SPDX-License-Identifier: CC-BY-SA-4.0
-->