#! /usr/bin/env tclsh
# Copyright (c) 2021 D. Bohdan.
# License: MIT.

namespace eval tclmark {
    variable interp
    variable renders 0
    variable token
    variable version 0.1.0

    namespace eval cmd {
        namespace path [namespace parent]
    }
}


proc tclmark::render {content {variables {}}} {
    variable interp
    variable renders
    variable token

    incr renders
    set interp tclmark-$renders

    # The token should be unguessable by the user.
    set token [binary format {iu1 f1 iu1} \
        $renders \
        [expr rand()] \
        [zlib crc32 $content] \
    ]

    try {
        interp create -safe $interp

        foreach command [interp eval $interp {info commands}] {
            $interp hide $command
        }

        foreach command [info commands cmd::*] {
            $interp alias \
                [namespace tail $command] \
                $command \
        }

        flatten [msubst $content]
    } finally {
        catch {
            interp delete $interp
        }
    }
}


proc tclmark::msubst content {
    variable interp
    variable token

    # Pass through already processed content marked with the
    # token.
    set tokenLen [string length $token]
    if {[string range $content 0 $tokenLen-1] eq $token} {
        return $content
    }

    set r [interp invokehidden \
        $interp \
        subst -nobackslashes -novariables $content \
    ]

    if {$r eq $content} {
        return [node text $content]
    }

    return [node tree $r]
}


proc tclmark::node {tag args} {
    variable token

    list $token $tag $args
}


proc tclmark::flatten node {
    variable token

    if {[llength $node] != 3} {
        error [list not three elements: $node]
    }
    lassign $node nodeToken tag data

    if {$nodeToken ne $token} {
        error [list invalid token in $node]
    }

    switch -- $tag {
        html {
            lindex $data 0
        }
        text {
            entities [lindex $data 0]
        }
        tree {
            join [lmap el $data {
                flatten $el
            }] {}
        }
        default {
            error [list unknown tag: $tag]
        }
    }
}


proc tclmark::entities text {
    string map {
        & &
        < &lt;
        > &gt;
        \" &quot;
        ' &#039;
    } $text
}


proc tclmark::cmd::b content {
    node tree [node html <b>] [msubst $content] [node html </b>]
}


proc tclmark::cmd::i content {
    node tree [node html <i>] [msubst $content] [node html </i>]
}


proc tclmark::generic-list {tag xs} {
    if {$tag ni {nl ol}} {
        error [list invalid tag: $tag
    }

    node tree \
        [node html <$tag>] \
        {*}[msubst-and-wrap li $xs] \
        [node html </$tag>] \
}


proc tclmark::cmd::1 args { tailcall generic-list nl $args }
proc tclmark::cmd::* args { tailcall generic-list ol $args }


proc tclmark::msubst-and-wrap {tag items} {
    lmap item $items {
        node tree [node html <$tag>] [msubst $item] [node html </$tag>]
    }
}


proc tclmark::run-tests {} {
    set stats [dict create total 0 passed 0 failed 0]

    proc test {name script arrow expected} {
        upvar stats stats

        dict incr stats total

        catch $script result

        set matched [switch -- $arrow {
            ->   { expr {$result eq $expected} }
            ->*  { string match $expected $result }
            ->$  { regexp -- $expected $result }
            default {
                return -code error \
                       -errorcode {JIMLIB TEST BAD-ARROW} \
                       [list unknown arrow: $arrow]
            }
        }]

        if {!$matched} {
            set error {}
            append error "\n>>>>> $name failed: [list $script]\n"
            append error "      got: [list $result]\n"
            append error " expected: [list $expected]"
            if {$arrow ne {->}} {
                append error "\n    match: $arrow"
            }

            dict incr stats failed

            puts stderr $error
            return
        }

        flatten [msubst $content]
    } finally {
        catch {
            interp delete $interp
        }
    }
}


proc tclmark::msubst content {
    variable interp
    variable token

    # Pass through already processed content marked with the
    # token.
    set tokenLen [string length $token]
    if {[string range $content 0 $tokenLen-1] eq $token} {
        return $content
    }

    set r [interp invokehidden \
        $interp \
        subst -nobackslashes -novariables $content \
    ]

    if {$r eq $content} {
        return [node text $content]
    }

    return [node tree $r]
}


proc tclmark::node {tag args} {
    variable token

    list $token $tag $args
}


proc tclmark::flatten node {
    variable token

    if {[llength $node] != 3} {
        error [list not three elements: $node]
    }
    lassign $node nodeToken tag data

    if {$nodeToken ne $token} {
        error [list invalid token in $node]
    }

    switch -- $tag {
        html {
            lindex $data 0
        }
        text {
            entities [lindex $data 0]
        }
        tree {
            join [lmap el $data {
                flatten $el
            }] {}
        }
        default {
            error [list unknown tag: $tag]
        }
    }
}


proc tclmark::entities text {
    string map {
        & &amp;
        < &lt;
        > &gt;
        \" &quot;
        ' &#039;
    } $text
}


proc tclmark::cmd::b content {
    node tree [node html <b>] [msubst $content] [node html </b>]
}


proc tclmark::cmd::i content {
    node tree [node html <i>] [msubst $content] [node html </i>]
}


proc tclmark::cmd::1 args {
    node tree \
        [node html <nl>] \
        {*}[msubst-and-wrap li $args] \
        [node html </nl>] \
}


proc tclmark::cmd::* args {
    node tree \
        [node html <ol>] \
        {*}[msubst-and-wrap li $args] \
        [node html </ol>] \
}


proc tclmark::msubst-and-wrap {tag items} {
    lmap item $items {
        node tree [node html <$tag>] [msubst $item] [node html </$tag>]
    }
}


proc tclmark::run-tests {} {
    set stats [dict create total 0 passed 0 failed 0]

    proc test {name script arrow expected} {
        upvar stats stats

        dict incr stats total

        catch $script result

        set matched [switch -- $arrow {
            ->   { expr {$result eq $expected} }
            ->*  { string match $expected $result }
            ->$  { regexp -- $expected $result }
            default {
                return -code error \
                       -errorcode {JIMLIB TEST BAD-ARROW} \
                       [list unknown arrow: $arrow]
            }
        }]

        if {!$matched} {
            set error {}
            append error "\n>>>>> $name failed: [list $script]\n"
            append error "      got: [list $result]\n"
            append error " expected: [list $expected]"
            if {$arrow ne {->}} {
                append error "\n    match: $arrow"
            }

            dict incr stats failed

            puts stderr $error
            return
        }

        dict incr stats passed
    }


    test basic-1 {
        tclmark::render Test
    } -> Test

    test basic-2 {
        tclmark::render {[b Test]}
    } -> <b>Test</b>

    test basic-3 {
        tclmark::render {[i {Hello, world!}]}
    } -> {<i>Hello, world!</i>}

    test basic-4 {
        tclmark::render {[b [i Test]]}
    } -> <b><i>Test</i></b>

    test basic-5 {
        tclmark::render {[b {[i Test]}]}
    } -> <b><i>Test</i></b>

    test basic-6 {
        tclmark::render {[}
    } -> \[


    test html-1 {
        tclmark::render {<b><i>Test</i></b>}
    } -> {&lt;b&gt;&lt;i&gt;Test&lt;/i&gt;&lt;/b&gt;}

    test html-2 {
        tclmark::render {[b <script>alert('Hello!')</script>]}
    } -> {<b>&lt;script&gt;alert(&#039;Hello!&#039;)&lt;/script&gt;</b>}


    test list-1 {
        tclmark::render {[* first second third]}
    } -> {<ol><li>first</li><li>second</li><li>third</li></ol>}

    test list-2 {
        tclmark::render {[1 first second third]}
    } -> {<nl><li>first</li><li>second</li><li>third</li></nl>}


    puts stderr $stats

    return [expr {[dict get $stats failed] > 0}]
}


# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    exit [tclmark::run-tests]
}

proc tclmark::cmd::b content {
    node tree [node html <b>] [msubst $content] [node html </b>]
}


proc tclmark::cmd::i content {
    node tree [node html <i>] [msubst $content] [node html </i>]
}


proc tclmark::run-tests {} {
    set stats [dict create total 0 passed 0 failed 0]

    proc test {name script arrow expected} {
        upvar stats stats

        dict incr stats total

        catch $script result

        set matched [switch -- $arrow {
            ->   { expr {$result eq $expected} }
            ->*  { string match $expected $result }
            ->$  { regexp -- $expected $result }
            default {
                return -code error \
                       -errorcode {JIMLIB TEST BAD-ARROW} \
                       [list unknown arrow: $arrow]
            }
        }]

        if {!$matched} {
            set error {}
            append error "\n>>>>> $name failed: [list $script]\n"
            append error "      got: [list $result]\n"
            append error " expected: [list $expected]"
            if {$arrow ne {->}} {
                append error "\n    match: $arrow"
            }

            dict incr stats failed

            puts stderr $error
            return
        }

        dict incr stats passed
    }


    test basic-1 {
        tclmark::render Test
    } -> Test

    test basic-2 {
        tclmark::render {[b Test]}
    } -> <b>Test</b>

    test basic-3 {
        tclmark::render {[i {Hello, world!}]}
    } -> {<i>Hello, world!</i>}

    test basic-4 {
        tclmark::render {[b [i Test]]}
    } -> <b><i>Test</i></b>

    test basic-5 {
        tclmark::render {[b {[i Test]}]}
    } -> <b><i>Test</i></b>

    test basic-6 {
        tclmark::render {[}
    } -> \[


    test html-1 {
        tclmark::render {<b><i>Test</i></b>}
    } -> {&lt;b&gt;&lt;i&gt;Test&lt;/i&gt;&lt;/b&gt;}

    test html-2 {
        tclmark::render {[b <script>alert('Hello!')</script>]}
    } -> {<b>&lt;script&gt;alert(&#039;Hello!&#039;)&lt;/script&gt;</b>}


    test list-1 {
        tclmark::render {[list first second third]}
    } -> {<ol><li>first</li><li>second</li><li>third</li></ol>}


    puts stderr $stats

    return [expr {[dict get $stats failed] > 0}]
}


# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    exit [tclmark::run-tests]
}

package provide tclmark 0
package provide tclmark 0
        dict incr stats passed
    }


    test basic-1 {
        tclmark::render Test
    } -> Test

    test basic-2 {
        tclmark::render {[b Test]}
    } -> <b>Test</b>

    test basic-3 {
        tclmark::render {[i {Hello, world!}]}
    } -> {<i>Hello, world!</i>}

    test basic-4 {
        tclmark::render {[b [i Test]]}
    } -> <b><i>Test</i></b>

    test basic-5 {
        tclmark::render {[b {[i Test]}]}
    } -> <b><i>Test</i></b>

    test basic-6 {
        tclmark::render {[}
    } -> \[


    test html-1 {
        tclmark::render {<b><i>Test</i></b>}
    } -> {&lt;b&gt;&lt;i&gt;Test&lt;/i&gt;&lt;/b&gt;}

    test html-2 {
        tclmark::render {[b <script>alert('Hello!')</script>]}
    } -> {<b>&lt;script&gt;alert(&#039;Hello!&#039;)&lt;/script&gt;</b>}


    test list-1 {
        tclmark::render {[* first second third]}
    } -> {<ol><li>first</li><li>second</li><li>third</li></ol>}

    test list-2 {
        tclmark::render {[1 first second third]}
    } -> {<nl><li>first</li><li>second</li><li>third</li></nl>}


    puts stderr $stats

    return [expr {[dict get $stats failed] > 0}]
}


# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    exit [tclmark::run-tests]
}

package provide tclmark 0