punkshell/scriptlib/developer/runtests_parity.tcl

#runtests_parity.tcl - compare two 'src/tests/runtests.tcl -report json' outputs for result parity.
#(agent-authored developer utility, 2026-07-18 - created for the -singleproc 0 multi-process
# runner completion: verifies per-file result parity between runner modes/interpreters/contexts)
#
#Usage:
#  tclsh scriptlib/developer/runtests_parity.tcl <a.json> <b.json>
#  tclsh scriptlib/developer/runtests_parity.tcl -names <a.txt> <b.txt>
#
#Default (json) mode: each input file is the captured stdout of a runtests.tcl run with
#-report json (or markdown+json): the last line starting with {"runner" is taken as the
#report, so preamble lines (argv echo, package-load warnings) and fenced markdown context
#are tolerated.
#
#Compared (deterministic result identity):
#  - top-level status and total/passed/skipped/failed tallies
#  - the set of test file paths
#  - per file: status, total/passed/skipped/failed, failure identities (name+status),
#    skip identities (name+reason), warning codes
#Ignored (expected to vary between runs/modes): microseconds, the slowest list,
#observed_* event counts.
#
#-names mode (added 2026-07-19 for G-092 test-file splits): each input is the captured
#stdout of a runtests.tcl run with '-report markdown -show-passes 1'. Every
#'- testname: <name>' line (pass, failure and constraint-skip sections all use this form)
#contributes to a MULTISET of test names with file attribution deliberately ignored, so
#moving tests verbatim between files compares identical while any lost, duplicated or
#renamed test is reported. NAMES: identical -> exit 0, differences -> exit 1.
#
#Exit codes: 0 = parity, 1 = differences found, 2 = usage or parse error.
#No package dependencies (runs under any tclsh 8.6+); contains a minimal JSON parser
#sufficient for the runner's machine-generated report format.

namespace eval jsonlite {
    variable str ""
    variable pos 0
    variable len 0

    proc parse {text} {
        variable str $text
        variable pos 0
        variable len [string length $text]
        return [parse_value]
    }
    proc fail {msg} {
        variable pos
        return -code error "jsonlite parse error at offset $pos: $msg"
    }
    proc skip_ws {} {
        variable str
        variable pos
        variable len
        while {$pos < $len && [string index $str $pos] in [list " " \t \n \r]} {
            incr pos
        }
    }
    proc parse_value {} {
        variable str
        variable pos
        variable len
        skip_ws
        if {$pos >= $len} {
            fail "unexpected end of input"
        }
        switch -- [string index $str $pos] {
            \{ {return [parse_object]}
            \[ {return [parse_array]}
            \" {return [parse_string]}
            t {
                if {[string range $str $pos $pos+3] ne "true"} {fail "bad literal"}
                incr pos 4
                return 1
            }
            f {
                if {[string range $str $pos $pos+4] ne "false"} {fail "bad literal"}
                incr pos 5
                return 0
            }
            n {
                if {[string range $str $pos $pos+3] ne "null"} {fail "bad literal"}
                incr pos 4
                return ""
            }
            default {return [parse_number]}
        }
    }
    proc parse_object {} {
        variable str
        variable pos
        incr pos ;#consume open brace
        set d [dict create]
        skip_ws
        if {[string index $str $pos] eq "\}"} {
            incr pos
            return $d
        }
        while 1 {
            skip_ws
            if {[string index $str $pos] ne "\""} {fail "expected object key"}
            set k [parse_string]
            skip_ws
            if {[string index $str $pos] ne ":"} {fail "expected : after object key"}
            incr pos
            dict set d $k [parse_value]
            skip_ws
            switch -- [string index $str $pos] {
                , {incr pos}
                \} {incr pos; return $d}
                default {fail "expected , or \} in object"}
            }
        }
    }
    proc parse_array {} {
        variable str
        variable pos
        incr pos ;#consume open bracket
        set out [list]
        skip_ws
        if {[string index $str $pos] eq "\]"} {
            incr pos
            return $out
        }
        while 1 {
            lappend out [parse_value]
            skip_ws
            switch -- [string index $str $pos] {
                , {incr pos}
                \] {incr pos; return $out}
                default {fail "expected , or \] in array"}
            }
        }
    }
    proc parse_string {} {
        variable str
        variable pos
        variable len
        incr pos ;#consume opening quote
        set out ""
        while {$pos < $len} {
            set q [string first "\"" $str $pos]
            set b [string first "\\" $str $pos]
            if {$q < 0} {
                fail "unterminated string"
            }
            if {$b < 0 || $q < $b} {
                append out [string range $str $pos [expr {$q - 1}]]
                set pos [expr {$q + 1}]
                return $out
            }
            append out [string range $str $pos [expr {$b - 1}]]
            set pos [expr {$b + 1}]
            set e [string index $str $pos]
            switch -- $e {
                \" {append out \"}
                \\ {append out \\}
                / {append out /}
                b {append out \b}
                f {append out \f}
                n {append out \n}
                r {append out \r}
                t {append out \t}
                u {
                    set hex [string range $str $pos+1 $pos+4]
                    if {[string length $hex] != 4 || ![string is xdigit -strict $hex]} {
                        fail "bad unicode escape"
                    }
                    scan $hex %x cp
                    append out [format %c $cp]
                    incr pos 4
                }
                default {fail "bad escape sequence \\$e"}
            }
            incr pos
        }
        fail "unterminated string"
    }
    proc parse_number {} {
        variable str
        variable pos
        variable len
        set start $pos
        while {$pos < $len && [string index $str $pos] in [list - + . e E 0 1 2 3 4 5 6 7 8 9]} {
            incr pos
        }
        set numtext [string range $str $start [expr {$pos - 1}]]
        if {$numtext eq "" || ![string is double -strict $numtext]} {
            fail "bad number '$numtext'"
        }
        return $numtext
    }
}

proc load_report {filename} {
    if {![file exists $filename]} {
        puts stderr "runtests_parity: file not found: $filename"
        exit 2
    }
    set fd [open $filename r]
    set data [read $fd]
    close $fd
    #the report is the last line containing the open-brace+"runner": marker. The marker may
    #not be at line start: the runner's punk ANSI output stack can emit an SGR reset sequence
    #on the same line immediately before the JSON, and other preamble/noise lines may precede it.
    set marker "\{\"runner\":"
    set report_line ""
    foreach ln [split $data \n] {
        set idx [string first $marker $ln]
        if {$idx >= 0} {
            set report_line [string trimright [string range $ln $idx end] \r]
        }
    }
    if {$report_line eq ""} {
        puts stderr "runtests_parity: no runtests JSON report line (containing \{\"runner\":) found in $filename"
        exit 2
    }
    if {[catch {jsonlite::parse $report_line} report]} {
        puts stderr "runtests_parity: could not parse JSON report in $filename: $report"
        exit 2
    }
    return $report
}

proc filemap {report} {
    set m [dict create]
    foreach tf [dict get $report testfiles] {
        dict set m [dict get $tf path] $tf
    }
    return $m
}

proc failure_sigs {tf} {
    set sigs [list]
    foreach f [dict get $tf failures] {
        lappend sigs "[dict get $f name] status=[dict get $f status]"
    }
    return [lsort $sigs]
}

proc skip_sigs {tf} {
    set sigs [list]
    foreach s [dict get $tf skips] {
        lappend sigs "[dict get $s name] reason=[dict get $s reason]"
    }
    return [lsort $sigs]
}

proc warning_sigs {tf} {
    set sigs [list]
    foreach w [dict get $tf warnings] {
        lappend sigs [dict get $w code]
    }
    return [lsort $sigs]
}

proc list_diff_lines {label lista listb} {
    set lines [list]
    foreach item $lista {
        if {$item ni $listb} {
            lappend lines "  $label only in A: $item"
        }
    }
    foreach item $listb {
        if {$item ni $lista} {
            lappend lines "  $label only in B: $item"
        }
    }
    return $lines
}

proc load_names {filename} {
    if {![file exists $filename]} {
        puts stderr "runtests_parity: file not found: $filename"
        exit 2
    }
    set fd [open $filename r]
    set data [read $fd]
    close $fd
    set names [list]
    foreach ln [split $data \n] {
        if {[regexp {^- testname: (.*?)\s*$} $ln -> nm]} {
            if {$nm ne ""} {
                lappend names $nm
            }
        }
    }
    if {![llength $names]} {
        puts stderr "runtests_parity: no '- testname:' lines found in $filename (expected captured stdout of: runtests.tcl -report markdown -show-passes 1)"
        exit 2
    }
    return $names
}

proc names_multiset {names} {
    set counts [dict create]
    foreach n $names {
        dict incr counts $n
    }
    return $counts
}

if {[lindex $argv 0] eq "-names"} {
    lassign [lrange $argv 1 end] filea fileb
    if {$filea eq "" || $fileb eq "" || [llength $argv] != 3} {
        puts stderr "usage: tclsh runtests_parity.tcl -names <a.txt> <b.txt>"
        puts stderr " where each file is captured stdout of: <tclsh> src/tests/runtests.tcl -report markdown -show-passes 1 ..."
        exit 2
    }
    set namesa [load_names $filea]
    set namesb [load_names $fileb]
    set counta [names_multiset $namesa]
    set countb [names_multiset $namesb]
    puts "runtests test-name comparison (multiset, file attribution ignored)"
    puts "A: $filea ([llength $namesa] name occurrences, [dict size $counta] distinct)"
    puts "B: $fileb ([llength $namesb] name occurrences, [dict size $countb] distinct)"
    set diffs [list]
    foreach nm [lsort [dict keys $counta]] {
        set ca [dict get $counta $nm]
        set cb [expr {[dict exists $countb $nm] ? [dict get $countb $nm] : 0}]
        if {$ca != $cb} {
            lappend diffs "$nm: A=$ca B=$cb"
        }
    }
    foreach nm [lsort [dict keys $countb]] {
        if {![dict exists $counta $nm]} {
            lappend diffs "$nm: A=0 B=[dict get $countb $nm]"
        }
    }
    if {[llength $diffs] == 0} {
        puts "NAMES: identical ([llength $namesa] test name occurrences)"
        exit 0
    }
    foreach d $diffs {
        puts "- $d"
    }
    puts "NAMES: DIFFER ([llength $diffs] names with differing counts)"
    exit 1
}

lassign $argv filea fileb
if {$filea eq "" || $fileb eq "" || [llength $argv] != 2} {
    puts stderr "usage: tclsh runtests_parity.tcl <a.json> <b.json>"
    puts stderr "       tclsh runtests_parity.tcl -names <a.txt> <b.txt>"
    puts stderr " where each json file is captured stdout of: <tclsh> src/tests/runtests.tcl -report json ..."
    exit 2
}

set ra [load_report $filea]
set rb [load_report $fileb]

set diffs [list]
foreach k {status total passed skipped failed} {
    set va [dict get $ra $k]
    set vb [dict get $rb $k]
    if {$va ne $vb} {
        lappend diffs "top-level $k: A=$va B=$vb"
    }
}

set ma [filemap $ra]
set mb [filemap $rb]
foreach path [dict keys $ma] {
    if {![dict exists $mb $path]} {
        lappend diffs "file only in A: $path"
    }
}
foreach path [dict keys $mb] {
    if {![dict exists $ma $path]} {
        lappend diffs "file only in B: $path"
    }
}

foreach path [dict keys $ma] {
    if {![dict exists $mb $path]} {
        continue
    }
    set tfa [dict get $ma $path]
    set tfb [dict get $mb $path]
    set flines [list]
    foreach k {status total passed skipped failed} {
        set va [dict get $tfa $k]
        set vb [dict get $tfb $k]
        if {$va ne $vb} {
            lappend flines "  $k: A=$va B=$vb"
        }
    }
    lappend flines {*}[list_diff_lines failure [failure_sigs $tfa] [failure_sigs $tfb]]
    lappend flines {*}[list_diff_lines skip [skip_sigs $tfa] [skip_sigs $tfb]]
    lappend flines {*}[list_diff_lines warning [warning_sigs $tfa] [warning_sigs $tfb]]
    if {[llength $flines]} {
        lappend diffs "file $path:"
        lappend diffs {*}$flines
    }
}

puts "runtests parity comparison"
puts "A: $filea"
puts "B: $fileb"
if {[llength $diffs] == 0} {
    puts "PARITY: ok (files=[llength [dict keys $ma]] total=[dict get $ra total] passed=[dict get $ra passed] skipped=[dict get $ra skipped] failed=[dict get $ra failed])"
    exit 0
}
foreach d $diffs {
    puts "- $d"
}
puts "PARITY: DIFFERS ([llength $diffs] difference lines)"
exit 1