@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::args 0.2. 3
# Application punk::args 0.3.1
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.2. 3]
#[manpage_begin punkshell_module_punk::args 0 0.3.1 ]
#[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 --}]
@ -416,7 +416,7 @@ tcl::namespace::eval ::punk::args::helpers {
}
if {$opt_title ne ""} {
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[a]"
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[punk::ansi:: a]"
} else {
set title ""
}
@ -911,6 +911,25 @@ tcl::namespace::eval punk::args {
env, envi, ... environment all normalize to environment.
(To require a longer minimum, reserve each shorter form:
reserving {en env} raises the minimum to envi.)
-choicealiases {<dict>}
Dictionary mapping alias names to canonical choice names.
An alias is accepted wherever its canonical choice is: an
exact alias match works regardless of -choiceprefix, and
when -choiceprefix is true alias names participate in
prefix calculation so a unique prefix of an alias also
matches. A matched alias is normalized: the parse result
contains the canonical choice, never the alias.
Aliases are not displayed as separate choice entries -
usage display folds them into the canonical entry as an
'(alias: name)' note on its label. -choicelabels keys
should be canonical names only.
An alias listed in -choiceprefixdenylist must be typed
in full (denial applies to the alias name; a canonical
reached via its alias is not subject to the canonical's
own denylist entry).
Each alias must map to an existing choice, and must not
itself collide with a choice (validated when the
definition is resolved).
-choicegroups {<dict>}
Generally this would be used instead of -choices to allow
usage display of choices grouped by some name (or the empty
@ -2642,6 +2661,17 @@ tcl::namespace::eval punk::args {
}
tcl::dict::set spec_merged -mash $specval
}
-choicealiases {
#dict of alias -> canonical choice (goal G-040).
#Aliases are accepted at parse (exact, and as prefix-calculation members when
#-choiceprefix applies) and normalize to their canonical choice in the parse
#result; usage display folds them into the canonical entry.
#Cross-validation against the final choice set happens after all specs merge.
if {![punk::args::lib::string_is_dict $specval]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary of alias -> canonical-choice @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-unindentedfields -
-solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2761,7 +2791,7 @@ tcl::namespace::eval punk::args {
-minsize -maxsize -choices -choicegroups
-mincap -maxcap
-choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-choicelabels -choiceinfo
-choicelabels -choiceinfo -choicealiases
-unindentedfields
-nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help
-multipleunique -choicemultipleunique -choicemultipleuniqueset
@ -2774,6 +2804,21 @@ tcl::namespace::eval punk::args {
}
} ;# end foreach {spec specval} argdef_values
#cross-validate -choicealiases against the final merged choice set (goal G-040)
if {[tcl::dict::exists $spec_merged -choicealiases] && [tcl::dict::size [tcl::dict::get $spec_merged -choicealiases]]} {
set ca_allchoices [punk::args::system::Dict_getdef $spec_merged -choices {}]
foreach {_cagroup camembers} [punk::args::system::Dict_getdef $spec_merged -choicegroups {}] {
lappend ca_allchoices {*}$camembers
}
tcl::dict::for {ca_alias ca_canonical} [tcl::dict::get $spec_merged -choicealiases] {
if {$ca_canonical ni $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' maps alias '$ca_alias' to '$ca_canonical' which is not in -choices/-choicegroups @id:$DEF_definition_id"
}
if {$ca_alias in $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' alias '$ca_alias' collides with a defined choice @id:$DEF_definition_id"
}
}
}
if {$is_opt} {
#tcl::dict::set FDICT ARG_CHECKS $argname {*}{
@ -4811,12 +4856,15 @@ tcl::namespace::eval punk::args {
if {$has_choices} {
if {$help ne ""} {append help \n}
#G-040: alias names participate in prefix calculation (as at parse time)
set choicealiases_display [Dict_getdef $arginfo -choicealiases {}]
set choicealias_names [dict keys $choicealiases_display]
if {[dict get $arginfo -nocase]} {
set casemsg " (case insensitive)"
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}[string tolower $choicealias_names] {*} $choiceprefixreservelist]
} else {
set casemsg " (case sensitive)"
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choicealias_names {*}$choice prefixreservelist]
}
if {[dict get $arginfo -choiceprefix]} {
set prefixmsg " (choice prefix allowed)"
@ -4825,6 +4873,22 @@ tcl::namespace::eval punk::args {
}
set choicelabeldict [Dict_getdef $arginfo -choicelabels {}]
set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}]
#G-040: aliases are not displayed as separate choice entries - fold each
#canonical's alias names into its label so every display path shows them once
if {[dict size $choicealiases_display]} {
set aliasesbycanonical [dict create]
dict for {ca_al ca_cn} $choicealiases_display {
dict lappend aliasesbycanonical $ca_cn $ca_al
}
dict for {ca_cn ca_als} $aliasesbycanonical {
set aliasnote "(alias[expr {[llength $ca_als] > 1 ? {es} : {}}]: [join $ca_als |])"
if {[dict exists $choicelabeldict $ca_cn]} {
dict set choicelabeldict $ca_cn "$aliasnote\n[dict get $choicelabeldict $ca_cn]"
} else {
dict set choicelabeldict $ca_cn $aliasnote
}
}
}
set formattedchoices [dict create] ;#use dict rather than array to preserve order
if {$help eq ""} {
#first line of help - no included base of 4 indent is the normal state of first help lines in definitions scripts
@ -8074,6 +8138,155 @@ tcl::namespace::eval punk::args {
#rename get_dict
#
#G-040: the single implementation of choice-word matching - shared by argument parsing
#(get_dict) and the punk::ns doc-lookup walk (cmd_traverse), so 'i <cmd> <word>'
#resolution can never diverge from what parsing accepts.
#Arguments:
# word - the supplied word (callers pass the check-form, e.g. ansistripped when applicable)
# nocase - value of -nocase for the argument
# allchoices - flat list of -choices plus all -choicegroups members (dups allowed)
# choicealiases - -choicealiases dict (alias -> canonical choice)
# choiceprefix - value of -choiceprefix
# denylist - -choiceprefixdenylist (full word required for these names)
# reservelist - -choiceprefixreservelist (phantom prefix-calculation members)
#Returns dict:
# matched - boolean: word identifies a choice (directly, by unique prefix, or via an alias)
# exact - boolean: the raw stored word already equals the resulting choice (no rewrite needed)
# canonical - the resulting choice value (empty when not matched)
proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist} {
set aliasnames [tcl::dict::keys $choicealiases]
set has_choicealiases [expr {[llength $aliasnames] > 0}]
set choicealiases_nocase [tcl::dict::create]
if {$has_choicealiases} {
tcl::dict::for {ca_al ca_cn} $choicealiases {
tcl::dict::set choicealiases_nocase [tcl::string::tolower $ca_al] $ca_cn
}
}
if {$nocase} {
set choices_test [tcl::string::tolower $allchoices]
set v_test [tcl::string::tolower $word]
} else {
set choices_test $allchoices
set v_test $word
}
set chosen ""
set choice_in_list 0
set choice_exact_match 0
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
if {$word in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
#(deliberately not 'exact' - the stored raw value must be overwritten with the canonical)
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$nocase && $v_test in $choices_test} {
#full-length match except for case
#select the case from the choice list - not the supplied value
foreach avail [lsort -unique $allchoices] {
if {[tcl::string::match -nocase $word $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
} else {
#PREFIX check required - any match here is not an exact match or it would have matched above.
#in this block we can treat empty result from prefix match as a non-match
set prefix_via_alias 0 ;#set when the prefix match landed on an alias name (deny already applied to the alias)
if {$nocase} {
#nocase prefixing with case-dups: see the -choiceprefixdenylist nocase notes at the original
#get_dict site - counterintuitive DEL/delete/Delete edge cases are documented feature-not-bug
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$bestmatch eq "" || $bestmatch in $reservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}[tcl::dict::keys $choicealiases_nocase] {*}$reservelist] $v_test]
if {$chosen ne "" && [tcl::dict::exists $choicealiases_nocase $chosen]} {
#matched an alias (lowercased) - deny applies to the alias name, then normalize
if {[lsearch -nocase $denylist $chosen] >= 0} {
set chosen ""
} else {
set chosen [tcl::dict::get $choicealiases_nocase $chosen]
set prefix_via_alias 1
}
set choice_in_list [expr {$chosen ne ""}]
} else {
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
}
} else {
if {$bestmatch in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$bestmatch in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $bestmatch]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $bestmatch
set choice_in_list 1
}
}
} else {
set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$matchedname eq "" || $matchedname in $reservelist} {
set chosen ""
set choice_in_list 0
} elseif {$matchedname in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$matchedname in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $matchedname]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $matchedname
set choice_in_list 1
}
}
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#(a canonical reached via an alias is exempt - deny was already applied to the alias name)
#review - case difference edge cases in choiceprefixdenylist !todo
if {!$prefix_via_alias && $chosen in $denylist} {
set choice_in_list 0
set chosen ""
}
}
} else {
#-choiceprefix false - exact matching only
if {$v_test in $choices_test} {
#value as stored is ok (raw word kept - historical behaviour, including nocase raw retention)
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
}
}
return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen]
}
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#only supports -flag val pairs, not solo options
@ -10023,6 +10236,10 @@ tcl::namespace::eval punk::args {
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}]
set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}]
#-choicealiases (G-040): alias -> canonical choice. Accepted exact (any -choiceprefix
#setting) and as prefix-calculation members when -choiceprefix is true; matched aliases
#normalize to their canonical choice in the parse result (see choiceword_match).
set choicealiases [Dict_getdef $thisarg -choicealiases {}]
set choicerestricted [tcl::dict::get $thisarg -choicerestricted]
set choicemultiple [tcl::dict::get $thisarg -choicemultiple]
if {[string is integer -strict $choicemultiple]} {
@ -10097,122 +10314,60 @@ tcl::namespace::eval punk::args {
set choice_in_list 0
set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple?
if {!$matches_default} {
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
set choice_exact_match 0
if {$c_check in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $c_check
set choice_in_list 1
set choice_exact_match 1
} elseif {$v_test in $choices_test} {
#assert - if we're here, nocase must be true
#we know choice is present as full-length match except for case
#now we want to select the case from the choice list - not the supplied value
#we don't set choice_exact_match - because we will need to override the optimistic existing val below
#review
foreach avail [lsort -unique $allchoices] {
if {[string match -nocase $c $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} else {
#puts ">>>> choiceprefixreservelist: $choiceprefixreservelist"
#PREFIX check required - any 'chosen' here is not an exact match or it would have matched above.
#assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above.
#in this block we can treat empty result from prefix match as a non-match
if {$nocase} {
#nocase implies that our entered value doesn't have to match case of choices -
#but we would still like to select the best match if there are case-dups.
#e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete
# selecting Del will find Delete, del will match delete (and raise error)
# but DEL will also match delete rather than Delete - so again an error is raised.
#This is counterintuitive with -nocase
#This is probably such an edge case that best served with documentation as a feature-not-bug
#Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete?
#The choice of the user to use -choiceprefixdenylist along with case-dups is the issue.
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test]
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
#G-040: choice-word matching delegated to the shared resolver
#(punk::args::choiceword_match - also consumed by the punk::ns doc-lookup
# walk, so 'i <cmd> <word>' resolution cannot diverge from parsing)
set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist]
set choice_in_list [tcl::dict::get $matchinfo matched]
set choice_exact_match [tcl::dict::get $matchinfo exact]
set chosen [tcl::dict::get $matchinfo canonical]
#override the optimistic existing val (prefix-normalized or alias-normalized matches)
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
set chosen $bestmatch
set choice_in_list 1
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$chosen eq "" || $chosen in $choiceprefixreservelist} {
set choice_in_list 0
} else {
set choice_in_list 1
}
}
#override choice_in_list if in deny list
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#review - case difference edge cases in choiceprefixdenylist !todo
if {$chosen in $choiceprefixdenylist} {
set choice_in_list 0
set chosen ""
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
}
}
#override the optimistic existing val
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
}
}
} else {
#value as stored in $dname is ok
set choice_in_list [expr {$v_test in $choices_test}]
}
}
@ -12395,7 +12550,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.2. 3
set version 0.3.1
}]
return
