@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::args 0.11. 2
# Application punk::args 0.12.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.11. 2]
#[manpage_begin punkshell_module_punk::args 0 0.12.0 ]
#[copyright "2024"]
#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}]
#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}]
@ -820,8 +820,17 @@ tcl::namespace::eval punk::args {
%B%@form%N% ?opt val...?
(used for commands with multiple forms)
directive-options: -form <list> -synopsis <string>
-overlapallowed <formname-list>
The -synopsis value allows overriding the auto-calculated
synopsis.
The -overlapallowed value names other forms this form is
KNOWN to overlap with (an argument list can cleanly match
both - e.g 'after cancel <id|script>' where real Tcl
disambiguates by runtime state). It sanctions the overlap
for punk::args::formcheck reporting only - parse behaviour
is unaffected (an ambiguous argument list still raises
multipleformmatches). Unknown form names are rejected when
the definition is resolved.
%B%@formdisplay%N% ?opt val...?
directive-options: -header <str> (text for header row of table)
-body <str> (override autogenerated arg info for form)
@ -3606,6 +3615,19 @@ tcl::namespace::eval punk::args {
dict for {fid FDICT} $F {
dict set F $fid {} ;#detach
#G-074: @form -overlapallowed sanctions a known form overlap for
#punk::args::formcheck reporting - it must name forms that exist in this
#definition. Validated here because all forms have been created by now.
#(the current form's key still exists in F while detached - self-reference
#is pointless but harmless and not rejected)
if {[dict exists $FDICT -overlapallowed]} {
foreach oaform [dict get $FDICT -overlapallowed] {
if {![dict exists $F $oaform]} {
error "punk::args::resolve - @form -overlapallowed for form '$fid' names unknown form '$oaform' (known forms: [dict keys $F]) @id:$DEF_definition_id"
}
}
}
#set mashargs [dict get $F $fid OPT_MASHES]
set mashargs [dict get $FDICT OPT_MASHES]
if {[llength $mashargs]} {
@ -6979,6 +7001,460 @@ tcl::namespace::eval punk::args {
return $ranked
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#G-074 punk::args::formcheck - on-demand multiform ambiguity analysis.
#Static pairwise pass over a definition's resolved FORMS: enumerate the positional
#word-slot chains each form can present, derive candidate witness arglists for
#aligned chains of equal length, and CONFIRM each candidate by parsing the witness
#against both forms (parse_status - no error raise, no user-supplied words).
#Only a witnessed overlap is reported, so fully discriminated form pairs cannot
#false-alarm; the documented miss direction is witness derivation - exotic types
#without a derivable witness word, required options (options are excluded from the
#positional model), and enumeration caps (-multiple repetitions, chain counts).
#Nothing here runs at define/resolve time apart from the cheap -overlapallowed
#known-form validation.
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#enumerate the positional word-slot chains a form can present - leaders then values,
#branching on -optional arguments and ?-wrapped optional clause members, with
#-multiple arguments capped at multiple_cap repetitions (same member pattern per
#repetition). Each chain is a list of slots {arg <argname> type <membertype>} - one
#slot per word position. @leaders/@values min/max windows are not re-checked here:
#every candidate overlap is confirmed by a real parse before being reported.
proc private::formcheck_chains {formdict {multiple_cap 2} {chain_cap 400}} {
set ARG_INFO [dict get $formdict ARG_INFO]
set chains [list {}]
foreach argname [list {*}[dict get $formdict LEADER_NAMES] {*}[dict get $formdict VAL_NAMES]] {
set typelist [dict get $ARG_INFO $argname -type]
#member patterns for a single occurrence of this argument
set patterns [list {}]
foreach tp $typelist {
if {[string match {\?*\?} $tp]} {
set inclusions [list "" [string trim $tp ?]]
} else {
set inclusions [list $tp]
}
set withmember [list]
foreach p $patterns {
foreach inc $inclusions {
if {$inc eq ""} {
lappend withmember $p
} else {
lappend withmember [list {*}$p $inc]
}
}
}
set patterns $withmember
}
#an occurrence consumes at least one word
set occurrence_patterns [lsearch -all -inline -not -exact $patterns {}]
if {![llength $occurrence_patterns]} {
continue
}
if {[dict get $ARG_INFO $argname -multiple]} {
set max_occurrences $multiple_cap
} else {
set max_occurrences 1
}
if {[dict get $ARG_INFO $argname -optional]} {
set min_occurrences 0
} else {
set min_occurrences 1
}
set newchains [list]
foreach chain $chains {
for {set occ $min_occurrences} {$occ <= $max_occurrences} {incr occ} {
if {$occ == 0} {
lappend newchains $chain
continue
}
foreach pat $occurrence_patterns {
set extended $chain
for {set r 0} {$r < $occ} {incr r} {
foreach membertype $pat {
lappend extended [dict create arg $argname type $membertype]
}
}
lappend newchains $extended
}
}
}
set chains $newchains
if {[llength $chains] > $chain_cap} {
#conservative truncation (documented miss direction)
set chains [lrange $chains 0 $chain_cap-1]
}
}
return $chains
}
#static description of one positional slot for overlap screening:
# disc 1 if the slot is a discriminator (literal/literalprefix alternates
# or a restricted choice set - the same notion as form_literal_affinity)
# discwords the discriminator's words (choice words, literal values)
# permissive 1 if any type alternate performs no word validation (any/none/string/
# ansistring/globstring/expr/script) - the 'type-weakness' side
# witnesses candidate words derivable from the types (a word satisfying the type)
proc private::formcheck_slotinfo {formdict slot} {
set ARG_INFO [dict get $formdict ARG_INFO]
set argname [dict get $slot arg]
set tp [string trim [dict get $slot type] ?]
set disc 0
set discwords [list]
set permissive 0
set witnesses [list]
if {[dict exists $ARG_INFO $argname -choices] || [dict exists $ARG_INFO $argname -choicegroups]} {
set choicewords [list]
if {[dict exists $ARG_INFO $argname -choices]} {
lappend choicewords {*}[dict get $ARG_INFO $argname -choices]
}
if {[dict exists $ARG_INFO $argname -choicegroups]} {
dict for {_grp grpmembers} [dict get $ARG_INFO $argname -choicegroups] {
lappend choicewords {*}$grpmembers
}
}
if {[Dict_getdef $ARG_INFO $argname -choicerestricted 1]} {
set disc 1
lappend discwords {*}$choicewords
} else {
#unrestricted choices don't discriminate but their words satisfy validation
lappend witnesses {*}$choicewords
}
}
foreach alt [split_type_expression $tp] {
if {[llength $alt] == 2} {
lassign $alt t param
switch -exact -- $t {
literal - literalprefix {
set disc 1
lappend discwords $param
}
stringstartswith - stringendswith - stringcontains {
lappend witnesses $param
}
default {}
}
} else {
switch -exact -- $alt {
any - none - string - ansistring - globstring - expr - script - "" {
set permissive 1
}
int - integer - number - bool - boolean {
lappend witnesses 1
}
double {
lappend witnesses 1.5
}
list {
lappend witnesses x
}
dict {
lappend witnesses {k v}
}
default {}
}
}
}
if {$permissive} {
lappend witnesses x
}
return [dict create disc $disc discwords $discwords permissive $permissive witnesses $witnesses]
}
#static acceptance screen of a word against a slot - returns yes|no|maybe.
#Restricted choice sets are screened via choiceword_match (the shared G-040
#resolver) so screening cannot diverge from parse acceptance; type alternates the
#screen doesn't model return maybe - the confirming parse decides. This screen only
#prunes candidate witnesses: a wrongly optimistic maybe costs a parse attempt, it
#cannot produce a false finding.
proc private::formcheck_slot_accepts {formdict slot word} {
set ARG_INFO [dict get $formdict ARG_INFO]
set argname [dict get $slot arg]
set tp [string trim [dict get $slot type] ?]
if {([dict exists $ARG_INFO $argname -choices] || [dict exists $ARG_INFO $argname -choicegroups])
&& [Dict_getdef $ARG_INFO $argname -choicerestricted 1]} {
#a restricted choice set rejects non-choice words regardless of type
set cw_allchoices [list]
if {[dict exists $ARG_INFO $argname -choices]} {
lappend cw_allchoices {*}[dict get $ARG_INFO $argname -choices]
}
if {[dict exists $ARG_INFO $argname -choicegroups]} {
dict for {_grp grpmembers} [dict get $ARG_INFO $argname -choicegroups] {
lappend cw_allchoices {*}$grpmembers
}
}
set cwm [choiceword_match $word\
[Dict_getdef $ARG_INFO $argname -nocase 0]\
$cw_allchoices\
[Dict_getdef $ARG_INFO $argname -choicealiases {}]\
[Dict_getdef $ARG_INFO $argname -choiceprefix 1]\
[Dict_getdef $ARG_INFO $argname -choiceprefixdenylist {}]\
[Dict_getdef $ARG_INFO $argname -choiceprefixreservelist {}]\
]
return [expr {[dict get $cwm matched] ? "yes" : "no"}]
}
set has_maybe 0
foreach alt [split_type_expression $tp] {
if {[llength $alt] == 2} {
lassign $alt t param
switch -exact -- $t {
literal {
if {$word eq $param} {return yes}
}
literalprefix {
if {$word ne "" && [string equal -length [string length $word] $word $param]} {return yes}
}
stringstartswith {
if {[string range $word 0 [string length $param]-1] eq $param} {return yes}
}
stringendswith {
set param_last [expr {[string length $param]-1}]
if {$param eq "" || [string range $word end-$param_last end] eq $param} {return yes}
}
stringcontains {
if {[string first $param $word] >= 0} {return yes}
}
default {
set has_maybe 1
}
}
} else {
switch -exact -- $alt {
any - none - string - ansistring - globstring - expr - script - "" {
return yes
}
int - integer {
if {[string is integer -strict $word]} {return yes}
}
number - double {
if {[string is double -strict $word]} {return yes}
}
bool - boolean {
if {[string is boolean -strict $word]} {return yes}
}
list {
if {![catch {llength $word}]} {return yes}
}
dict {
if {![catch {dict size $word}]} {return yes}
}
default {
set has_maybe 1
}
}
}
}
return [expr {$has_maybe ? "maybe" : "no"}]
}
#overlap check of one form pair. For each pair of equal-length slot chains, derive
#per-position candidate witness words (discriminator words and type witnesses from
#both slots, screened by formcheck_slot_accepts) and confirm candidates with a real
#single-form parse of the witness against BOTH forms. Returns a finding dict
#(forms/class/length/witness/slots) for the first confirmed witness, or {} if no
#candidate was confirmed within the parse budget.
#class: type_weakness if some witness position aligns a discriminator with a
#permissive (non-validating) type on the other side; structural otherwise (the
#forms genuinely share an argument shape - 'after cancel id|script' class).
proc private::formcheck_pair {id spec fa fb {parse_budget 32}} {
set fda [dict get $spec FORMS $fa]
set fdb [dict get $spec FORMS $fb]
set chains_b_bylen [dict create]
foreach cb [formcheck_chains $fdb] {
dict lappend chains_b_bylen [llength $cb] $cb
}
set parses 0
foreach ca [formcheck_chains $fda] {
set L [llength $ca]
if {$L == 0 || ![dict exists $chains_b_bylen $L]} {continue}
foreach cb [dict get $chains_b_bylen $L] {
#per-position candidate words + relation classification
set positions [list]
set viable 1
for {set i 0} {$i < $L} {incr i} {
set slota [lindex $ca $i]
set slotb [lindex $cb $i]
set ia [formcheck_slotinfo $fda $slota]
set ib [formcheck_slotinfo $fdb $slotb]
set candidates [list] ;#{word score} - score 2: both sides screened yes
foreach w [list {*}[dict get $ia discwords] {*}[dict get $ib discwords]\
{*}[dict get $ia witnesses] {*}[dict get $ib witnesses]] {
if {[lsearch -exact -index 0 $candidates $w] >= 0} {continue}
set acc_a [formcheck_slot_accepts $fda $slota $w]
set acc_b [formcheck_slot_accepts $fdb $slotb $w]
if {$acc_a eq "no" || $acc_b eq "no"} {continue}
lappend candidates [list $w [expr {($acc_a eq "yes") + ($acc_b eq "yes")}]]
}
if {![llength $candidates]} {
set viable 0
break
}
set candidates [lrange [lsort -integer -decreasing -index 1 $candidates] 0 2]
if {[dict get $ia disc] && ![dict get $ib disc] && [dict get $ib permissive]} {
set relation discriminator_vs_permissive
} elseif {[dict get $ib disc] && ![dict get $ia disc] && [dict get $ia permissive]} {
set relation discriminator_vs_permissive
} elseif {[dict get $ia disc] && [dict get $ib disc]} {
set relation shared_discriminator
} else {
set relation co_satisfiable_types
}
lappend positions [list [lmap c $candidates {lindex $c 0}] $relation\
[dict get $slota arg] [dict get $slotb arg]]
}
if {!$viable} {continue}
#witness combinations: best candidate per position, then vary one
#position at a time through its alternates
set base [lmap p $positions {lindex $p 0 0}]
set trylist [list $base]
for {set i 0} {$i < $L} {incr i} {
foreach altword [lrange [lindex $positions $i 0] 1 end] {
set varied $base
lset varied $i $altword
lappend trylist $varied
}
}
foreach witness $trylist {
if {$parses >= $parse_budget} {break}
incr parses 2
if {![dict get [parse_status $witness -form [list $fa] withid $id] ok]} {continue}
if {![dict get [parse_status $witness -form [list $fb] withid $id] ok]} {continue}
#confirmed overlap - classify and report
set class structural
set slotreport [list]
for {set i 0} {$i < $L} {incr i} {
lassign [lindex $positions $i] _cands relation arga argb
if {$relation eq "discriminator_vs_permissive"} {
set class type_weakness
}
lappend slotreport [dict create word [lindex $witness $i]\
args [list $arga $argb] relation $relation]
}
return [dict create forms [list $fa $fb] class $class length $L\
witness $witness slots $slotreport]
}
if {$parses >= $parse_budget} {break}
}
if {$parses >= $parse_budget} {break}
}
return {}
}
lappend PUNKARGS [list {
@id -id ::punk::args::formcheck
@cmd -name punk::args::formcheck\
-summary\
"Analyse a multiform definition for form pairs an argument list could match simultaneously."\
-help\
"Analyse the definition identified by id for AMBIGUOUS form pairs: pairs
of @form forms for which some argument list cleanly matches both, so a
parse without -form would raise a multipleformmatches error.
The analysis is static-first: it aligns the positional argument slots of
each form pair (leaders then values - options are order-free and excluded
from the positional model), derives candidate 'witness' argument lists,
and only reports a pair after CONFIRMING a witness by parsing it against
both forms individually. A reported overlap is therefore always real -
fully discriminated form pairs cannot be false-alarmed - while the miss
direction is conservative: overlaps whose witness the analysis cannot
derive (exotic validation types, forms requiring options, deep -multiple
repetition) may go unreported. No user-supplied argument words are
parsed, and definitions that never call formcheck pay no cost at
define/resolve time.
Finding classes:
type_weakness a discriminator slot (literal()/literalprefix()
alternates or a restricted choice set) in one form
aligns with a permissive type that performs no word
validation (any/none/string/ansistring/globstring/
expr/script) in the other - the permissive type
swallows the discriminator word (e.g 'lseq 1 count 5':
range's end slot typed number|expr accepts the word
'count'). Usually fixable by tightening the type.
structural the forms genuinely share an argument shape with no
discriminating slot difference (e.g 'after cancel x'
where x is id-shaped - real Tcl disambiguates by
runtime state). If intended, sanction the pair with
@form -overlapallowed so it reports as acknowledged.
A pair sanctioned via @form -overlapallowed <formname-list> (on either
member) is still reported, with sanctioned 1 - the sanction documents
intent for this analysis only and never changes parse behaviour.
Returns a dict:
id the analysed definition id
form_names declared forms in declaration order
pairs every form pair analysed (list of 2-element lists)
findings dict keyed by pair {formA formB} - each finding has
forms, class, length, witness (a confirmed argument
list matching both forms), slots (per-position word,
argument names and slot relation) and sanctioned (0|1)
unsanctioned pair keys of findings not covered by -overlapallowed
(the actionable subset - e.g a verification gate can
require this to be empty)
summary human-readable report of the above
With -return summary only the summary text is returned."
-return -type string -default dict -choices {dict summary} -help\
"dict: full machine-parsable analysis (includes the summary as a key).
summary: the human-readable report text only."
@values -min 1 -max 1
id -type string -help\
"id of a punk::args definition (as accepted by punk::args::get_spec)"
}]
proc formcheck {args} {
set argd [punk::args::parse $args withid ::punk::args::formcheck]
lassign [dict values $argd] leaders opts values received
set id [dict get $values id]
set opt_return [dict get $opts -return]
set spec [get_spec $id]
if {$spec eq ""} {
error "punk::args::formcheck - no such id: '$id'"
}
set form_names [dict get $spec form_names]
set pairs [list]
set findings [dict create]
set unsanctioned [list]
for {set i 0} {$i < [llength $form_names]} {incr i} {
for {set j [expr {$i+1}]} {$j < [llength $form_names]} {incr j} {
set fa [lindex $form_names $i]
set fb [lindex $form_names $j]
lappend pairs [list $fa $fb]
set finding [private::formcheck_pair $id $spec $fa $fb]
if {$finding eq ""} {continue}
set sanctioned 0
if {$fb in [Dict_getdef $spec FORMS $fa -overlapallowed {}]
|| $fa in [Dict_getdef $spec FORMS $fb -overlapallowed {}]} {
set sanctioned 1
}
dict set finding sanctioned $sanctioned
dict set findings [list $fa $fb] $finding
if {!$sanctioned} {
lappend unsanctioned [list $fa $fb]
}
}
}
set summarylines [list]
lappend summarylines "punk::args::formcheck $id: [llength $form_names] form(s), [llength $pairs] pair(s) analysed, [dict size $findings] overlap(s) ([llength $unsanctioned] unsanctioned)"
dict for {pairkey finding} $findings {
lassign $pairkey fa fb
set tag [expr {[dict get $finding sanctioned] ? "sanctioned" : "UNSANCTIONED"}]
lappend summarylines " $tag [dict get $finding class] overlap: $fa vs $fb - witness arglist {[dict get $finding witness]} parses cleanly against both forms"
foreach slot [dict get $finding slots] {
lassign [dict get $slot args] arga argb
lappend summarylines " word '[dict get $slot word]' satisfies $fa/$arga and $fb/$argb ([dict get $slot relation])"
}
}
if {![dict size $findings]} {
lappend summarylines " no overlapping form pairs detected (static analysis - see the punk::args::formcheck help for the miss/report boundary)"
}
set summary [join $summarylines \n]
if {$opt_return eq "summary"} {
return $summary
}
return [dict create id $id form_names $form_names pairs $pairs findings $findings unsanctioned $unsanctioned summary $summary]
}
lappend PUNKARGS [list {
@id -id ::punk::args::parse_status
@cmd -name punk::args::parse_status\
@ -14371,7 +14847,7 @@ package provide punk::args [tcl::namespace::eval punk::args {
tcl::namespace::path {::punk::args::lib ::punk::args::system}
variable pkg punk::args
variable version
set version 0.11. 2
set version 0.12.0
}]
return
