html {
    head {
        title {str "HTML demo"}
        meta -charset utf-8
        script -type text/javascript -src demo.js
    }
    body -onload onloadfunc() {
        global env
        h1 {str "Patch level: "; font -color blue {info patchlevel}}
        a -href https://wiki.tcl-lang.org/44439 {str "Source code"}
        p
        table -border 1 -cellspacing 0 {
            tr -style {background: yellow;} {
                foreach n {Name Value} {
                    th {str $n}
                }
            }
            dict for {name value} [array get env H*] {
                if {[string length $value] > 20} continue
                tr {
                    td {str $name}
                    td {str $value}
                }
            }
        }
    }
}

namespace eval html {
    namespace export html
    namespace eval gen {}
    namespace path gen

    # Helper command to create commands for html tags
    proc createtag {args} {
        ::foreach tag $args {
            ::proc $tag args [format {tailcall tag %s {*}$args} $tag]
        }
    }

    # Command that simply returns the string passed to it
    proc str {str} {return $str}
    proc % {args} {return [join $args]}

    proc nbsp {{str ""}} {
        if {$str ne ""} {
            return $str
        } else {
            return { }
        }
    }

    # Loop commands that collect the output of the commands in the loop body
    proc foreach args {
        tailcall htmleach {*}$args
    }
    proc for {init test next body} {
        tailcall htmlfor $init $test $next $body
    }
    proc while {test body} {
        tailcall htmlfor {} $test {} $body
    }
    # Create an alternative dict ensemble
    namespace ensemble create -command dict \
      -map [dict replace [namespace ensemble configure dict -map] \
      for gen::dictfor set gen::dictset]

    # Versions of commands that should not generate output
    proc set {var val} {
        uplevel 1 [list ::set $var $val]
        return
    }
    proc append {var args} {
        uplevel 1 [list ::append $var {*}$args]
        return
    }
    proc incr {var {val 1}} {
        uplevel 1 [list ::incr $var $val]
        return
    }
    proc lset {args} {
        uplevel 1 [list ::lset {*}$args]
        return
    }
    proc lappend {var args} {
        uplevel 1 [list ::lappend $var {*}$args]
        return
    }

    proc if {test args} {
        tailcall htmlif $test $args
    }

    proc html args {
        tag html {*}$args
    }

    # Create procs for the most common html tags
    createtag head body title link meta script style frame frameset noframes
    createtag i b u font samp span address cite em kbd code tt var sub sup
    createtag a img br hrule p pre blockquote div center iframe legend
    createtag h1 h2 h3 h4 h5 h6 ul ol li dl dt dd dir
    createtag table tbody caption colgroup col tr th td
    createtag form input select optgroup option button textarea label fieldset

    # Redefine proc (for this namespace only!)
    proc proc {name arglist body} {
        ::set func [list $arglist]
        ::lappend func [format {return [runbody %s 1]} [list $body]]
        ::lappend func [namespace current]
        ::set template {tailcall apply %s {*}[lrange [info level 0] 1 end]}
        ::proc $name $arglist [format $template [list $func]]
    }
}

proc html::gen::buildscript {level args} {
    upvar 1 script script
    append script {*}$args
    set retval ""
    set rc 0
    if {![string is space $script]} {
        if {![info complete $script]} {return $retval}
        set rc [catch {uplevel $level $script} retval]
    }
    set script {}
    return -code $rc $retval
}

proc html::gen::runbody {body {level 2}} {
    set retval ""
    incr level
    foreach line [split $body \n] {
        set rc [catch {
            set chunks [lassign [split $line ";"] chunk]
            append retval [buildscript $level $chunk]
            foreach chunk $chunks {
                append retval [buildscript $level ";" $chunk]
            }
            append retval [buildscript $level \n]
        } str]
        if {$rc != 0} {
            append retval $str
            return -code $rc $retval
        }
    }
    return $retval
}

proc html::gen::quote {str} {
    if {[string first {"} $str] < 0} {
        # String doesn't contain double quotes so default quoting can be used.
        return [format {"%s"} $str]
    } elseif {[string first {'} $str] < 0} {
        # String contains double quotes, but no single quotes.
        return [format {'%s'} $str]
    } else {
        # Both types of quotes are present.
        return [format {"%s"} [string map {\" &quot;} $str]]
    }
}

proc html::gen::tag {name args} {
    if {[llength $args] & 1} {
        set body [lindex $args end]
        set args [lrange $args 0 end-1]
    } else {
        set body {}
    }
    set tag $name
    foreach {option value} $args {
        if {$option eq "-style"} {
            set list [lsearch -all -inline -regexp [split $value ";\n"] {\S}]
            set value "[join [lmap n $list {string trim $n}] {; }];"
        }
        append tag " " [string range $option 1 end]=[quote $value]
    }
    # Check for empty tags which don't get an endtag
    # http://www.w3.org/TR/html401/index/elements.html
    if {
        $name in {
            area base basefont br col frame hr
            img input isindex link meta param
        }
    } {
        return <$tag>\n
    }

    set rc 0
    set str ""
    if {$body ne ""} {
        set rc [catch {runbody $body} str]
    }
    if {[string first \n $str] >= 0} {
        set retval "<$tag>\n[string trimright $str \n]\n</$name>"
    } else {
        set retval "<$tag>$str</$name>"
    }
    if {$name ni {html b i}} {
        append retval \n
    }
    return -code $rc $retval
}

proc html::gen::htmlif {test rest} {
    # Figure out which body to execute, if any
    while {[llength $rest]} {
        set rest [lassign $rest body]
        if {$body eq "then"} {set rest [lassign $rest body]}
        if {[uplevel 1 [list expr $test]]} {
            break
        } else {
            set rest [lassign $rest body]
            if {$body eq "elseif"} {
                set rest [lassign $rest test]
            } else {
                if {$body eq "else"} {
                    set rest [lassign $rest body]
                }
                break
            }
        }
        set body {}
    }
    # Run the selected body and collect the results
    set rc [catch {runbody $body} retval]
    return -code $rc $retval
}   

proc html::gen::htmleach {args} {
    # Use weird variable names to minimize the risk of a clash
    set j7idQ?nC [lindex $args end]
    set 3^mIF9h, [lrange $args 0 end-1]
    foreach {n -} ${3^mIF9h,} {
        foreach v $n {
            lappend varlist $v $v
        }
    }
    unset n v args
    upvar 1 {*}$varlist
    set Vk2|.n!J ""
    foreach {*}${3^mIF9h,} {
        set 6HPr_#MK [catch {runbody ${j7idQ?nC}} ^j%LOmyc]
        append Vk2|.n!J ${^j%LOmyc}
        if {${6HPr_#MK} == 2 || ${6HPr_#MK} == 3} break
    }
    return ${Vk2|.n!J}
}

proc html::gen::htmlfor {init test next body} {
    set retval ""
    uplevel 1 $init
    while {[uplevel 1 [list expr $test]]} {
        set rc [catch {runbody $body} str]
        append retval $str
        if {$rc == 3} break
        if {$rc == 2} {return -code $rc $retval}
        uplevel 1 $next
    }
    return $retval
}

proc html::gen::dictset {var args} {
    uplevel 1 [list ::dict set $var {*}$args]
    return
}

proc html::gen::dictfor {vars dict body} {
    lassign $vars keyvar valvar
    upvar 1 $keyvar key $valvar val
    set retval ""
    dict for {key val} $dict {
        set rc [catch {runbody $body} str]
        append retval $str
        if {$rc == 3} break
        if {$rc == 2} {return -code $rc $retval}
    }
    return $retval
}

namespace import html::html