lmatch - first cut

# this really wants to use [cmdsplit] so $arr(spacey key) and [string is digit] can work as patterns without quoting

# switch -glob matching literal []{}*:  a special king of quoting hell

source debug.tcl
namespace eval lmatch {

    proc lmatch args {
        options {-compare ::tcl::mathop::eq ::tcl::mathop::== glob lmatch}
        arguments {pattern list}
        if {$compare eq "glob"} {
            set compare {string match}
        } elseif {$compare eq "nocase"} {
            set compare {string compare -nocase}
        }
        set pi 0
        set li 0
        try {
            while {$pi < [llength $pattern]} {
                set pat [lindex $pattern $pi]
                set val [lindex $list $li]
                switch -glob $pat {
                    \\* {    # match any single element
                        incr li ; incr pi
                    }
                    \\*\\* - \{\\*\}\\* {     # match any N elements
                        set pi2 [expr {$pi + 1}]
                        if {$pi2 >= [llength $pattern]} {
                            return 1
                        }
                        for {set li2 $li} {$li2 < [llength $list]} {incr li2} {
                            if {[uplevel 1 [list lmatch [lrange $pattern $pi2 end] [lrange $list $li2 end]]]} {
                                return 1
                            }
                        }
                        throw {LMATCH FAIL} "Failed to unify after **: [list [lrange $pattern $pi end] [lrange $list $pi end]]"
                    }
                    $* {    # match a variable's value in the enclosing scope
                        set lit [uplevel 1 [list subst $pat]]
                        if {$lit ne $val} { # NOTE: this case disregards -compare!
                            throw {LMATCH FAIL} "{$val} does not match {$lit} (value of $pat)"
                        }
                        incr li ; incr pi
                    }
                    \\[*\\] {   # match with a command  - FIXME:  commands break list parsing, duh
                        set cmd [string range $pat 1 end-1]
                        if {![uplevel 1 $cmd [list $val]]} {
                            throw {LMATCH FAIL} "{$val} is not \[$cmd\]"
                        }
                        incr li ; incr pi
                    }
                    default {   # match a literal value
                        puts "Comparing $pat with $val"
                        if {![$compare $pat $val]} {
                            throw {LMATCH FAIL} "{$val} ne {$pat}"
                        }
                        incr li ; incr pi
                    }
                }
            }
            if {$pi == [llength $pattern] && $li == [llength $list]} {
                return 1
            }
            return 0
        } trap {LMATCH FAIL} {e o} {
            debug log {Match failed: $e at pattern index $li ($pat), value index $li ($val)}
            return 0
        }

    }

    proc lbind args {
        options
        arguments {pattern list}
    }

    namespace export {[a-z]*}

    proc test {} {
        set c foop
        debug assert { [lmatch {a B} {a B}] }
        debug assert {![lmatch {a B} {a b}] }
        debug assert { [lmatch {a *} {a b}] }
        debug assert {![lmatch {a *} {a b c}] }
        debug assert { [lmatch {**} {}] }
        debug assert { [lmatch {**} {a b c}] }
        debug assert { [lmatch {a **} {a b c}] }
        debug assert { [lmatch {a ** c} {a b c}] }
        debug assert {![lmatch {a * $c} {a B}] }
        debug assert {![lmatch {a * $c} {a B food}] }
        debug assert { [lmatch {a * $c} {a B foop}] }
        debug assert { [catch {lmatch {a * $nonesuch} {a B foop}}] }
        debug assert { [lmatch {"[string is digit]" a *} {123 a B}] }
        return 1
    }
}

catch {rename ::lmatch {}}  ;# turns out Tclx uses this name with arguments reversed :(
namespace import ::lmatch::*
try {
    ::lmatch::test
} on error {e o} {
    puts "ERROR: $e"
    pdict $o
}