#!/usr/bin/env tclsh
# testbody_lint.tcl - lint tcltest .test files for result-yield authoring defects
#
# The defect class (see src/tests/AGENTS.md Local Contracts and the tcl-runtests
# agent skill): tcltest compares the -body's RETURN VALUE against -result, so a
# body whose final command always returns the empty string (a loop, unset,
# close ...) discards whatever the body computed - the test can never pass, and
# the FAILED report shows an empty actual far from the cause. A related shape
# passes VACUOUSLY: a test invocation with no -body at all (e.g. a missing
# description lets the braced description word swallow all the option words)
# runs an empty body against the default -result "" and reports PASS.
#
# Findings (E = error, exit 1; W = warning, reported but exit stays 0):
#   E empty-ender : final -body command always returns "" but the test's
#                   -result (under its -match mode) cannot match "" (skipped
#                   when -returnCodes expects an abnormal completion)
#   E no-body     : test invocation carrying no -body option
#   E incomplete  : a file or namespace-eval block whose final command never
#                   completes - an unbalanced brace ANYWHERE (including inside
#                   a # comment) kills the whole file's parse
#   W odd-shape   : a test invocation whose argument shape the linter cannot
#                   interpret (reported so it is never silently unchecked)
#
# Convention being backed: bodies that accumulate into $result end with an
# explicit `set result` or `return $result` (tcltest's default -returnCodes
# {ok return} accepts the return form and -cleanup still runs; an explicit
# -returnCodes list omitting `return` rejects it loudly).
#
# Plain tclsh (8.6+ or 9), no package dependencies:
#   tclsh scriptlib/developer/testbody_lint.tcl                 ;# lints src/tests
#   tclsh scriptlib/developer/testbody_lint.tcl <dir-or-file> ?...?
#   tclsh scriptlib/developer/testbody_lint.tcl -stats          ;# adds final-command distribution
#   tclsh scriptlib/developer/testbody_lint.tcl -selftest       ;# embedded fixtures
# Exit 0 when clean (warnings allowed), 1 on E-level findings, 2 usage/environment.

# ---------------------------------------------------------------- script splitting
# Split a script into top-level command chunks by [info complete] line
# accumulation. Returns a list of {startline chunktext} pairs; a non-empty
# leftover tail (the unbalanced-brace parse-killer class) is returned as a
# chunk whose text carries a leading \x00INCOMPLETE\x00 marker.
proc split_script {script} {
    set chunks {}
    set cur ""
    set startline 1
    set lineno 0
    foreach line [split $script \n] {
        incr lineno
        if {$cur eq ""} {
            set startline $lineno
        }
        append cur $line \n
        if {[info complete $cur]} {
            lappend chunks [list $startline $cur]
            set cur ""
        }
    }
    if {[string trim $cur] ne ""} {
        lappend chunks [list $startline "\x00INCOMPLETE\x00$cur"]
    }
    return $chunks
}

# Split ONE command's text into its words without substitution. Outer braces
# and quotes are stripped (one level). Handles backslash-newline whitespace -
# including the corpus style `{description}\` with the continuation backslash
# hard against the closing brace, which is legal command syntax but NOT list
# syntax (so [lindex]/[lrange] on the command text would error) - bracket
# nesting in bare words, and literal `{*}{...}` argument expansion (spliced;
# dynamic `{*}$x`/`{*}[...]` expansions are kept as single opaque words).
proc cmdwords {cmd} {
    set words {}
    set types {}
    set i 0
    set prevend -1
    set n [string length $cmd]
    while {$i < $n} {
        while {$i < $n} {
            set c [string index $cmd $i]
            if {$c eq " " || $c eq "\t" || $c eq "\n"} { incr i ; continue }
            if {$c eq "\\" && [string index $cmd $i+1] eq "\n"} { incr i 2 ; continue }
            break
        }
        if {$i >= $n} break
        set wstart $i
        set c [string index $cmd $i]
        if {$c eq "\{"} {
            set depth 1
            set j [expr {$i+1}]
            while {$j < $n && $depth > 0} {
                set d [string index $cmd $j]
                if {$d eq "\\"} { incr j 2 ; continue }
                if {$d eq "\{"} { incr depth } elseif {$d eq "\}"} { incr depth -1 }
                incr j
            }
            set text [string range $cmd $i+1 $j-2]
            set type brace
            set i $j
        } elseif {$c eq "\""} {
            set j [expr {$i+1}]
            while {$j < $n} {
                set d [string index $cmd $j]
                if {$d eq "\\"} { incr j 2 ; continue }
                if {$d eq "\""} break
                incr j
            }
            set text [string range $cmd $i+1 $j-1]
            set type quote
            set i [expr {$j+1}]
        } else {
            set j $i
            set bdepth 0
            while {$j < $n} {
                set d [string index $cmd $j]
                if {$d eq "\\"} { incr j 2 ; continue }
                if {$d eq "\["} { incr bdepth }
                if {$d eq "\]" && $bdepth > 0} { incr bdepth -1 }
                if {$bdepth == 0 && ($d eq " " || $d eq "\t" || $d eq "\n")} break
                incr j
            }
            set text [string range $cmd $i $j-1]
            set type bare
            set i $j
        }
        if {[llength $words] && [lindex $types end] eq "brace" && [lindex $words end] eq "*" && $wstart == $prevend} {
            # the previous word was a braced * hard against this word: {*}word
            set words [lrange $words 0 end-1]
            set types [lrange $types 0 end-1]
            if {$type eq "brace" && ![catch {llength $text}]} {
                foreach el $text {
                    lappend words $el
                    lappend types expanded
                }
            } else {
                lappend words "{*}$text"
                lappend types opaque
            }
        } else {
            lappend words $text
            lappend types $type
        }
        set prevend $i
    }
    return $words
}

# Last non-comment command of a script; returns {lineoffset text} where text is
# \x00INCOMPLETE\x00 when the script never completes (unbalanced quote/brace).
proc last_command {body} {
    set last {}
    foreach pair [split_script $body] {
        lassign $pair ln chunk
        set t [string trim $chunk]
        if {$t eq "" || [string index $t 0] eq "#"} continue
        if {[string match "\x00INCOMPLETE\x00*" $chunk]} {
            return [list $ln "\x00INCOMPLETE\x00"]
        }
        set last [list $ln $t]
    }
    return $last
}

# ---------------------------------------------------------------- classification
# Command words (and first-two-word pairs) that ALWAYS return the empty string.
set EMPTY1 {foreach while for unset proc destroy close puts update vwait rename}
set EMPTY2 {{array set} {array unset} {namespace delete} {namespace forget}
            {dict for} {file delete} {file mkdir} {file copy} {file rename}
            {chan close} {chan puts} {interp delete}}

# Can the empty string satisfy this -result under this -match mode?
proc result_matchable_empty {res matchmode} {
    switch -- $matchmode {
        exact {
            return [expr {$res eq ""}]
        }
        glob {
            if {[catch {string match $res ""} m]} { return 1 }
            return $m
        }
        regexp {
            if {[catch {regexp -- $res ""} m]} { return 1 }
            return $m
        }
        default {
            # custom match commands - cannot judge, never flag
            return 1
        }
    }
}

# ---------------------------------------------------------------- lint engine
proc lint_reset {} {
    set ::stats [dict create files 0 tests 0]
    set ::enddist [dict create]
    set ::findings {}
}

proc flag {path line level rule name detail} {
    lappend ::findings [dict create path $path line $line level $level rule $rule name $name detail $detail]
}

proc lint_file {path} {
    set f [open $path r]
    fconfigure $f -encoding utf-8
    set src [read $f]
    close $f
    dict incr ::stats files
    scan_script $path $src 0
}

proc scan_script {path src baseline} {
    global EMPTY1 EMPTY2
    foreach pair [split_script $src] {
        lassign $pair chunkline chunk
        set startline [expr {$baseline + $chunkline}]
        if {[string match "\x00INCOMPLETE\x00*" $chunk]} {
            flag $path $startline E incomplete "" "script never completes from this line - an unbalanced brace (possibly inside a comment) kills the file's parse"
            continue
        }
        set t [string trim $chunk]
        if {$t eq "" || [string index $t 0] eq "#"} continue
        set w0 ""
        regexp {^(\S+)} $t -> w0
        if {$w0 eq "namespace"} {
            # recurse into namespace eval wrappers (the corpus-wide pattern)
            set words [cmdwords $t]
            if {[lindex $words 1] eq "eval"} {
                set nsbody [lindex $words end]
                if {[string first \n $nsbody] >= 0} {
                    set idx [string first $nsbody $chunk]
                    set off 0
                    if {$idx > 0} {
                        set off [regexp -all {\n} [string range $chunk 0 [expr {$idx-1}]]]
                    }
                    scan_script $path $nsbody [expr {$startline - 1 + $off}]
                }
            }
            continue
        }
        if {$w0 ni {test tcltest::test ::tcltest::test}} continue
        dict incr ::stats tests
        set words [cmdwords $t]
        set name [lindex $words 1]
        if {[llength $words] < 3} {
            flag $path $startline W odd-shape $name "test invocation with fewer than 3 words - linter cannot check it"
            continue
        }
        set body "" ; set hasbody 0 ; set res "" ; set rcodes "" ; set match exact
        if {[llength $words] == 3 || [string index [lindex $words 3] 0] eq "-"} {
            # option form: test name description ?-flag value ...?
            set tail [lrange $words 3 end]
            if {[llength $tail] % 2 != 0} {
                flag $path $startline W odd-shape $name "odd option/value word count - linter cannot check it"
                continue
            }
            set badkey ""
            foreach {k v} $tail {
                if {[string index $k 0] ne "-"} { set badkey $k ; break }
                switch -- $k {
                    -body        { set body $v ; set hasbody 1 }
                    -result      { set res $v }
                    -returnCodes { set rcodes $v }
                    -match       { set match $v }
                }
            }
            if {$badkey ne ""} {
                flag $path $startline W odd-shape $name "expected an option at word '[string range $badkey 0 40]' - linter cannot check it"
                continue
            }
            if {!$hasbody} {
                flag $path $startline E no-body $name "test invocation has no -body (a missing description makes the braced description swallow the option words) - the test passes vacuously"
                continue
            }
        } else {
            # legacy positional form: test name description ?constraints? body result
            set tail [lrange $words 3 end]
            switch -- [llength $tail] {
                2 { lassign $tail body res ; set hasbody 1 }
                3 { lassign $tail cons body res ; set hasbody 1 }
                default {
                    flag $path $startline W odd-shape $name "unrecognised positional argument shape - linter cannot check it"
                    continue
                }
            }
        }
        lassign [last_command $body] lastln lastcmd
        if {$lastcmd eq "\x00INCOMPLETE\x00"} {
            flag $path $startline W odd-shape $name "-body does not parse as a script - linter cannot check it"
            continue
        }
        if {$lastcmd eq ""} continue
        set lw [cmdwords $lastcmd]
        set e0 [lindex $lw 0]
        set e1 [lindex $lw 1]
        set key $e0
        if {[list $e0 $e1] in $EMPTY2} { set key "$e0 $e1" }
        dict incr ::enddist $key
        set rc_abnormal 0
        foreach tok $rcodes {
            if {$tok in {error 1 break 3 continue 4}} { set rc_abnormal 1 }
        }
        if {!$rc_abnormal && ($e0 in $EMPTY1 || [list $e0 $e1] in $EMPTY2) && ![result_matchable_empty $res $match]} {
            flag $path $startline E empty-ender $name "final -body command '$key' always returns empty but -result ($match match) cannot match empty - end the body with 'set result' or 'return \$result'"
        }
    }
}

proc walk {path} {
    if {[file isfile $path]} {
        lint_file $path
        return
    }
    foreach sub [lsort [glob -nocomplain -directory $path *]] {
        if {[file isdirectory $sub]} {
            walk $sub
        } elseif {[string match *.test $sub]} {
            lint_file $sub
        }
    }
}

proc report {opt_stats} {
    set errors 0
    foreach f $::findings {
        if {[dict get $f level] eq "E"} { incr errors }
        set name [dict get $f name]
        if {$name ne ""} { set name " $name" }
        puts "[dict get $f path]:[dict get $f line]: [dict get $f level] [dict get $f rule]$name - [dict get $f detail]"
    }
    puts "testbody_lint: [dict get $::stats files] files, [dict get $::stats tests] tests, $errors error(s), [expr {[llength $::findings] - $errors}] warning(s)"
    if {$opt_stats} {
        puts "final -body command distribution:"
        set sorted [lsort -integer -decreasing -index 1 [lmap {k v} $::enddist {list $k $v}]]
        foreach pair $sorted {
            lassign $pair k v
            puts [format "  %6d  %s" $v $k]
        }
    }
    return $errors
}

# ---------------------------------------------------------------- selftest
proc selftest {} {
    set fails {}

    # helper: run the scanner over fixture text, return list of {rule line} pairs
    proc st_scan {src} {
        lint_reset
        scan_script fx $src 0
        return [lmap f $::findings {list [dict get $f rule] [dict get $f line]}]
    }

    set fx_good {test g1 {desc} -body {
    set result {}
    foreach x {a b} { lappend result $x }
    set result
} -result {a b}
test g2 {desc} -body {
    set result {}
    foreach x {a b} { lappend result $x }
    return $result
} -result {a b}
test g3 {desc} -body {
    lappend result done
} -result {done}
test g4 {desc} -body {
    set ok 1
    foreach x {a b} { if {$x eq "c"} { set ok 0 } }
    set ok
    # trailing comment is ignored when finding the final command
} -result 1}
    set got [st_scan $fx_good]
    if {$got ne ""} { lappend fails "good fixture flagged: $got" }
    if {[dict get $::stats tests] != 4} { lappend fails "good fixture: expected 4 tests, got [dict get $::stats tests]" }

    set fx_bad {test b1 {desc} -body {
    set result {}
    foreach x {a b} { lappend result $x }
} -result {a b}}
    set got [st_scan $fx_bad]
    if {$got ne {{empty-ender 1}}} { lappend fails "empty-ender fixture: expected {{empty-ender 1}}, got $got" }

    set fx_nobody {test n1 {
    -setup {set result ""} -body {
        set result done
    } -result done
}
test n2 {desc} -result 1}
    set got [st_scan $fx_nobody]
    if {$got ne {{no-body 1} {no-body 6}}} { lappend fails "no-body fixture: expected {{no-body 1} {no-body 6}}, got $got" }

    set fx_match {test m1 {desc} -body {
    foreach x {a} {}
} -match glob -result *
test m2 {desc} -body {
    foreach x {a} {}
} -match glob -result {a*}
test m3 {desc} -body {
    foreach x {a} {}
} -match regexp -result {^$}
test m4 {desc} -body {
    foreach x {a} {}
} -match regexp -result {abc}}
    set got [st_scan $fx_match]
    if {$got ne {{empty-ender 4} {empty-ender 10}}} { lappend fails "match fixture: expected m2/m4 flagged, got $got" }

    set fx_rcodes {test r1 {desc} -body {
    if {1} { error oops }
    foreach x {a} {}
} -returnCodes error -result oops}
    set got [st_scan $fx_rcodes]
    if {$got ne ""} { lappend fails "returnCodes fixture flagged: $got" }

    set fx_expand {test e1 {desc} {*}{
    }   -setup {set result ""} -body {
        lappend result ok
    }                                       {*}{
    }   -result [list {*}{
        ok
    }]}
    set got [st_scan $fx_expand]
    if {$got ne ""} { lappend fails "expand fixture flagged: $got" }
    if {[dict get $::stats tests] != 1} { lappend fails "expand fixture: expected 1 test, got [dict get $::stats tests]" }

    set fx_nseval {namespace eval ::t {
    namespace import ::tcltest::*
    test v1 {desc}\
        -body {
            set result x
            foreach x {a} {}
        }\
        -result x
}}
    set got [st_scan $fx_nseval]
    if {$got ne {{empty-ender 3}}} { lappend fails "nseval fixture: expected {{empty-ender 3}}, got $got" }

    set fx_incomplete "test t1 {d} -body \{\n    set x 1\n"
    set got [st_scan $fx_incomplete]
    if {$got ne {{incomplete 1}}} { lappend fails "incomplete fixture: expected {{incomplete 1}}, got $got" }

    if {[llength $fails]} {
        foreach f $fails { puts "selftest FAIL: $f" }
        return 1
    }
    puts "selftest: PASS (8 fixtures)"
    return 0
}

# ---------------------------------------------------------------- main
set opt_stats 0
set opt_selftest 0
set paths {}
foreach a $argv {
    switch -- $a {
        -stats    { set opt_stats 1 }
        -selftest { set opt_selftest 1 }
        default {
            if {[string index $a 0] eq "-"} {
                puts stderr "testbody_lint: unknown option '$a' (known: -stats -selftest)"
                exit 2
            }
            lappend paths $a
        }
    }
}

if {$opt_selftest} {
    exit [selftest]
}

if {![llength $paths]} {
    set root [file dirname [file dirname [file dirname [file normalize [info script]]]]]
    set default [file join $root src tests]
    if {![file isdirectory $default]} {
        puts stderr "testbody_lint: default target '$default' not found - pass a directory or file"
        exit 2
    }
    set paths [list $default]
}

lint_reset
foreach p $paths {
    if {![file exists $p]} {
        puts stderr "testbody_lint: no such path '$p'"
        exit 2
    }
    walk $p
}
exit [expr {[report $opt_stats] ? 1 : 0}]