From ef14dbbe91836699c00de7c7f1f44b4e7c8c7a4b Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Fri, 10 Jul 2026 14:50:21 +1000 Subject: [PATCH] update bootsupport + vfs + layout bootsupport: punk::args 0.4.2, punk::ns 0.1.4 Build outputs from 'make.tcl project' (punkcheck-managed old->new version renames: args-0.4.0/ns-0.1.3 pruned, args-0.4.2/ns-0.1.4 installed across src/bootsupport, _vfscommon.vfs and the punk.project/punk.shell layout bootsupport copies). Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com --- .../punk/{args-0.4.0.tm => args-0.4.2.tm} | 607 +++++++++++++----- .../modules/punk/ns-0.1.4.tm} | 46 +- .../bootsupport/modules/punk/args-0.4.2.tm} | 607 +++++++++++++----- .../src/bootsupport/modules/punk/ns-0.1.4.tm} | 46 +- .../bootsupport/modules/punk/args-0.4.2.tm} | 607 +++++++++++++----- .../src/bootsupport/modules/punk/ns-0.1.4.tm} | 46 +- .../punk/{args-0.4.0.tm => args-0.4.2.tm} | 607 +++++++++++++----- .../_vfscommon.vfs/modules/punk/ns-0.1.4.tm} | 46 +- 8 files changed, 1972 insertions(+), 640 deletions(-) rename src/bootsupport/modules/punk/{args-0.4.0.tm => args-0.4.2.tm} (97%) rename src/{project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm => bootsupport/modules/punk/ns-0.1.4.tm} (99%) rename src/project_layouts/custom/_project/{punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.0.tm => punk.project-0.1/src/bootsupport/modules/punk/args-0.4.2.tm} (97%) rename src/{bootsupport/modules/punk/ns-0.1.3.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm} (99%) rename src/project_layouts/custom/_project/{punk.project-0.1/src/bootsupport/modules/punk/args-0.4.0.tm => punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.2.tm} (97%) rename src/{vfs/_vfscommon.vfs/modules/punk/ns-0.1.3.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm} (99%) rename src/vfs/_vfscommon.vfs/modules/punk/{args-0.4.0.tm => args-0.4.2.tm} (97%) rename src/{project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm => vfs/_vfscommon.vfs/modules/punk/ns-0.1.4.tm} (99%) diff --git a/src/bootsupport/modules/punk/args-0.4.0.tm b/src/bootsupport/modules/punk/args-0.4.2.tm similarity index 97% rename from src/bootsupport/modules/punk/args-0.4.0.tm rename to src/bootsupport/modules/punk/args-0.4.2.tm index 06065b32..23ed8406 100644 --- a/src/bootsupport/modules/punk/args-0.4.0.tm +++ b/src/bootsupport/modules/punk/args-0.4.2.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.4.0 +# Application punk::args 0.4.2 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.4.0] +#[manpage_begin punkshell_module_punk::args 0 0.4.2] #[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 --}] @@ -1266,6 +1266,7 @@ tcl::namespace::eval punk::args { variable rawdef_cache_about variable id_cache_rawdef variable rawdef_cache_argdata + variable argdefcache_display if {[id_exists $id]} { if {!$quiet} { puts stderr "punk::args::undefine clearing existing data for id:$id" @@ -1274,11 +1275,13 @@ tcl::namespace::eval punk::args { set deflist [dict get $id_cache_rawdef $id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } else { dict for {k v} $rawdef_cache_argdata { if {[dict get $v id] eq $id} { dict unset rawdef_cache_argdata $k + dict unset argdefcache_display $k } } dict for {k v} $rawdef_cache_about { @@ -1314,16 +1317,390 @@ tcl::namespace::eval punk::args { proc undefine_deflist {deflist} { variable rawdef_cache_about variable id_cache_rawdef - variable rawdef_cache_argdata + variable rawdef_cache_argdata + variable argdefcache_display if {[dict exists $rawdef_cache_about $deflist -id]} { set id [dict get $rawdef_cache_about $deflist -id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } } + # -- --- --- --- --- --- --- --- --- --- --- + # G-046 display-field deferral + # Expansion of ${...} content landing in display-only fields (-help on @cmd/@examples + # and argument records, @formdisplay -header/-body) is deferred out of resolve: the + # parse spec stores inert tokens plus a DISPLAY_DEFERRED map, and display consumers + # (arg_error, eg, resolved_def) expand on demand via private::expand_display_fields. + # -choicelabels stays eager - punk::ns reads it directly from parse specs during the + # subcommand walk. + variable argdefcache_display [tcl::dict::create] ;#display-expanded specs (non-dynamic definitions), keyed by raw deflist + variable display_expanding [list] ;#definition ids currently being display-expanded (reentrancy guard) + + proc private::split_definition_records {optionspecs} { + #definition text -> list of records (factored out of resolve - G-046) + #records are delimited by newlines, but multiline values are allowed if properly + #quoted/braced - 'info complete' (on ansi-stripped accumulation) finds record ends. + set records [list] + set linebuild "" + set linelist [split $optionspecs \n] + set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. + #find the first record's base indent + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all record_base_indent + break ;#break at first non-empty + } + set in_record_continuation 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + set record_id 0 + set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record + foreach rawline $linelist { + set record_so_far [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_record [punk::ansi::ansistrip $record_so_far] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_record [string map [list \x1b\[ ""] $record_so_far] + } + if {![tcl::info::complete $test_record]} { + if {$in_record_continuation} { + #trim only the whitespace corresponding to the record indent - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + assert {$record_line == 0} punk::args::private::split_definition_records record_line + regexp {(\s*).*} $rawline _all record_base_indent + append linebuild $rawline \n + set in_record_continuation 1 + } + incr record_line + } else { + #either we're on a single line record, or last line of multiline record + if {$record_line != 0} { + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + #prep for next record + set in_record_continuation 0 + incr record_id + set record_line 0 + } + } + if {$in_record_continuation} { + puts stderr "punk::args::resolve incomplete record:" + puts stderr "$linebuild" + } + return $records + } + + proc private::classify_display_tokens {placeholdertext tokenlist} { + #G-046: return the subset of tokenlist whose tokens land in display-only field + #values. Display-only: -help on @cmd/@examples and on argument records, and + #@formdisplay -header/-body. Everything else (record names, -choices, -default, + #-choicelabels, @form -synopsis, directive settings) is parse/synopsis-relevant + #and stays eagerly expanded. + set display_tokens [list] + if {![llength $tokenlist]} { + return $display_tokens + } + set records [split_definition_records $placeholdertext] + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + if {[catch {set record_values [lassign $trimrec firstword]}]} { + continue ;#unparseable here - real errors surface in resolve's own record loop + } + if {[llength $record_values] % 2 != 0} { + continue + } + switch -glob -- $firstword { + @cmd - @examples { + set displaykeys {-help} + } + @formdisplay { + set displaykeys {-header -body} + } + @* { + set displaykeys {} + } + default { + #argument record + set displaykeys {-help} + } + } + if {![llength $displaykeys]} {continue} + foreach {k v} $record_values { + if {$k in $displaykeys && [string first \x01PADEFER $v] >= 0} { + foreach tk $tokenlist { + if {$tk ni $display_tokens && [string first $tk $v] >= 0} { + lappend display_tokens $tk + } + } + } + } + } + return $display_tokens + } + + proc private::mask_display_params {normargs defspace is_dynamic} { + #G-046 phases 0-2: extract ${...} params without evaluation (tstr -eval 0), + #classify which land in display-only fields, and return + # [list ] + #Blocks without display params are returned untouched (original text) so the + #normal tstr path processes them bit-identically. + set blockparts [list] + set tokenlist [list] + set n 0 + set phtext "" + foreach block $normargs { + if {[string first \$\{ $block] >= 0} { + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $block] ptlist paramlist + set btokens [list] + set phblock "" + set i 0 + foreach param $paramlist { + set tk [tcl::string::cat \x01 PADEFER [incr n] \x02] + append phblock [lindex $ptlist $i] $tk + lappend btokens $tk + incr i + } + append phblock [lindex $ptlist $i] + lappend blockparts [list 1 $ptlist $paramlist $btokens] + lappend tokenlist {*}$btokens + append phtext $phblock \n + } else { + lappend blockparts [list 0 {} {} {}] + append phtext $block \n + } + } + if {![llength $tokenlist]} { + return [list $normargs {}] + } + set display_tokens [classify_display_tokens $phtext $tokenlist] + if {![llength $display_tokens]} { + return [list $normargs {}] + } + set deferred [tcl::dict::create] + set outblocks [list] + foreach block $normargs bp $blockparts { + lassign $bp hasparams ptlist paramlist btokens + if {!$hasparams} { + lappend outblocks $block + continue + } + set block_display 0 + foreach tk $btokens { + if {$tk in $display_tokens} { + set block_display 1 + break + } + } + if {!$block_display} { + lappend outblocks $block + continue + } + set masked "" + set i 0 + foreach param $paramlist tk $btokens { + append masked [lindex $ptlist $i] + if {$tk in $display_tokens} { + append masked $tk + tcl::dict::set deferred $tk [tcl::dict::create source $param defspace $defspace dynamic $is_dynamic] + } else { + #parse-relevant param - reconstruct for normal tstr evaluation + append masked [tcl::string::cat \$\{ $param \}] + } + incr i + } + append masked [lindex $ptlist $i] + lappend outblocks $masked + } + return [list $outblocks $deferred] + } + + proc private::expand_display_fields {spec} { + #G-046: expand deferred display-field content of a parse spec on demand. + #Returns the spec with display fields expanded and DISPLAY_DEFERRED emptied. + #Non-dynamic expansions are cached (keyed by raw deflist); @dynamic definitions + #re-expand each call so provider changes refresh (matching resolve semantics). + if {![tcl::dict::exists $spec DISPLAY_DEFERRED]} { + return $spec + } + set map [tcl::dict::get $spec DISPLAY_DEFERRED] + if {![tcl::dict::size $map]} { + return $spec + } + set id [tcl::dict::get $spec id] + upvar ::punk::args::id_cache_rawdef id_cache_rawdef + upvar ::punk::args::rawdef_cache_about rawdef_cache_about + upvar ::punk::args::argdefcache_display argdefcache_display + set deflist "" + set spec_dynamic 0 + if {[tcl::dict::exists $id_cache_rawdef $id]} { + set deflist [tcl::dict::get $id_cache_rawdef $id] + if {[tcl::dict::exists $rawdef_cache_about $deflist -dynamic]} { + set spec_dynamic [tcl::dict::get $rawdef_cache_about $deflist -dynamic] + } + } + if {!$spec_dynamic && $deflist ne "" && [tcl::dict::exists $argdefcache_display $deflist]} { + return [tcl::dict::get $argdefcache_display $deflist] + } + upvar ::punk::args::display_expanding display_expanding + if {$id in $display_expanding} { + #reentrancy: deferred content is (indirectly) rendering help for an id whose + #display expansion is already in progress. Substitute the raw ${...} sources + #instead of evaluating - resolves cleanly, never loops. Not cached. + return [expand_display_slots $spec $map raw] + } + lappend display_expanding $id + try { + set spec [expand_display_slots $spec $map eval] + } finally { + set posn [lsearch -exact $display_expanding $id] + set display_expanding [lreplace $display_expanding $posn $posn] + } + tcl::dict::set spec DISPLAY_DEFERRED {} + if {!$spec_dynamic && $deflist ne ""} { + tcl::dict::set argdefcache_display $deflist $spec + } + return $spec + } + + proc private::expand_display_slots {spec map mode} { + #walk the display-only slots of a spec and expand deferred tokens in place + foreach infokey {cmd_info examples_info} { + if {[tcl::dict::exists $spec $infokey -help]} { + set v [tcl::dict::get $spec $infokey -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec $infokey -help [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {fid fdict} [tcl::dict::get $spec FORMS] { + if {[tcl::dict::exists $fdict FORMDISPLAY]} { + tcl::dict::for {k v} [tcl::dict::get $fdict FORMDISPLAY] { + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid FORMDISPLAY $k [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {argname arginfo} [tcl::dict::get $fdict ARG_INFO] { + if {[tcl::dict::exists $arginfo -help]} { + set v [tcl::dict::get $arginfo -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid ARG_INFO $argname -help [expand_deferred_text $v $map $mode] + } + } + } + } + return $spec + } + + proc private::expand_deferred_text {text map mode} { + #replace deferred display tokens in a field value. + #mode 'eval': substitute each token's ${...} source in its recorded definition + #namespace; @dynamic sources get the second substitution round (the ${$DYN_X} + #idiom). mode 'raw': substitute the raw ${...} source text (reentrancy path). + #Multiline results align continuation lines with the leading whitespace of the + #token's line - the same 'line' paramindents treatment punk::args::lib::tstr + #applies to eagerly expanded params (G-046 item 2 for the @dynamic path). + set out "" + set firstline 1 + foreach ln [split $text \n] { + if {!$firstline} { + append out \n + } + set firstline 0 + if {[string first \x01PADEFER $ln] < 0} { + append out $ln + continue + } + regexp {^(\s*)} $ln _all lineindent + while {[regexp -indices {\x01PADEFER[0-9]+\x02} $ln tokenposns]} { + lassign $tokenposns t0 t1 + set token [string range $ln $t0 $t1] + set replacement "" + if {[tcl::dict::exists $map $token]} { + set param [tcl::dict::get $map $token source] + set defspace [tcl::dict::get $map $token defspace] + set dynamic [tcl::dict::get $map $token dynamic] + if {$defspace eq ""} { + set defspace :: + } + if {$mode eq "raw"} { + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {[catch {tcl::namespace::eval $defspace [list ::subst $param]} presult]} { + #tstr behaviour on evaluation error: substitute the raw placeholder source + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {$dynamic && [string first \$\{ $presult] >= 0} { + #@dynamic second-round substitution + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $presult] ptlist2 paramlist2 + set r2 "" + set i 0 + foreach param2 $paramlist2 { + append r2 [lindex $ptlist2 $i] + if {[catch {tcl::namespace::eval $defspace [list ::subst $param2]} p2result]} { + append r2 [tcl::string::cat \$\{ $param2 \}] + } else { + append r2 $p2result + } + incr i + } + append r2 [lindex $ptlist2 $i] + set presult $r2 + } + set replacement $presult + } + } + } + if {$lineindent ne "" && [string first \n $replacement] >= 0} { + set rlines [split $replacement \n] + set replacement [lindex $rlines 0] + foreach rl [lrange $rlines 1 end] { + append replacement \n $lineindent $rl + } + } + set ln [string replace $ln $t0 $t1 $replacement] + } + append out $ln + } + return $out + } + # -- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { @id -id ::punk::args::resolve @cmd -name punk::args::resolve\ @@ -1403,12 +1780,14 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: -help section processing is sometimes expensive (e.g tcl syntax + #highlighted examples) and isn't required for parsing of arguments. Display-only + #${...} params are masked with inert tokens here and expanded on demand at + #display time (private::expand_display_fields) with a separate cache. + set deferred_display {} + lassign [private::mask_display_params $normargs $defspace 0] normargs deferred_display + set optionspecs [list] - #REVIEW - whilst this is only done once for each command definition, the -help section processing is sometimes expensive, - #and isn't required for parsing of arguments, so it unnecessarily slows first use of a command that uses punk::args and is heavily documented, - #especially if it has tcl syntax highlighted examples. - #- ideally we would delay expansion of -help sections until needed for display, - #and use a different cache key for the parsing vs display versions of the resolved definition. foreach block $normargs { if {[string first \$\{ $block] >= 0} { if {$defspace ne ""} { @@ -1443,10 +1822,11 @@ tcl::namespace::eval punk::args { #} } else { + set deferred_display {} if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { #cached - so first round of substitution already done set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist + lassign $pt_params ptlist paramlist deferred_display set optionspecs "" #subst is only being called on the parameters (contents of ${..}) foreach pt $ptlist param $paramlist { @@ -1463,6 +1843,11 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: mask display-only ${...} params (see non-dynamic branch note). + #Masked at round 1, so display payloads (including their round-2 + #${$DYN_X} providers) never run during argument resolution. + lassign [private::mask_display_params $normargs $defspace 1] normargs deferred_display + set optionspecs [list] foreach block $normargs { if {[string first \$\{ $block] >= 0} { @@ -1498,8 +1883,8 @@ tcl::namespace::eval punk::args { append optionspecs $pt [uplevel $LVL [list ::subst $param]] } } - #key is the raw def, value is the 2 element list of textparts, paramparts - tcl::dict::set argdefcache_unresolved $cache_key $pt_params + #key is the raw def, value is the list of textparts, paramparts (and the G-046 deferred display map) + tcl::dict::set argdefcache_unresolved $cache_key [list {*}$pt_params $deferred_display] } else { #wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required" @@ -1557,141 +1942,7 @@ tcl::namespace::eval punk::args { #set opt_solos [list] #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. - #find the first record's base indent - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all record_base_indent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $record_base_indent]" - set in_record_continuation 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - set record_id 0 - set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record - foreach rawline $linelist { - #puts stderr "$record_line $rawline" - #XXX - #set rawtrimmed [string trim $rawline] - #if {$in_record_continuation && $rawtrimmed ne "" && [string index $rawtrimmed 0] ni [list "\}" {"} "#"]} { - # regexp {(\s*).*} $rawline _ rawline_indent - # if {[string length $rawline_indent] <= [string length $record_base_indent]} { - # lappend records $linebuild - # set linebuild "" - # #prep for next record - # set in_record_continuation 0 - # incr record_id - # set record_line 0 - # } - #} - set record_so_far [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_record [punk::ansi::ansistrip $record_so_far] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_record [string map [list \x1b\[ ""] $record_so_far] - } - if {![tcl::info::complete $test_record]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record_continuation} { - #incr record_line - #if {$record_line == 1} { - # #first continuation line sets the indent - #} - - #/// - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - - #trim only the whitespace corresponding to last record indent or record_base_indent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - } else { - assert {$record_line == 0} punk::args::resolve record_line - regexp {(\s*).*} $rawline _all record_base_indent - #puts "indent: [ansistring VIEW -lf 1 $record_base_indent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - set in_record_continuation 1 - } - incr record_line - } else { - #either we're on a single line record, or last line of multiline record - - if {$record_line != 0} { - #trim only the whitespace corresponding to record_base_indent or record_base_indent + 4 spaces - not all whitespace on left - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline - #} else { - # append linebuild $rawline - #} - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - #prep for next record - set in_record_continuation 0 - incr record_id - set record_line 0 - } - } - if {$in_record_continuation} { - puts stderr "punk::args::resolve incomplete record:" - puts stderr "$linebuild" - } - #puts stderr 1[lindex $records 1] - #puts stderr 4[lindex $records 4] - #puts stderr 5[lindex $records 5] - #puts stderr 6[lindex $records 6] + set records [private::split_definition_records $optionspecs] set cmd_info {} set package_info {} @@ -1854,7 +2105,9 @@ tcl::namespace::eval punk::args { #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] + #G-046: expand any deferred display content of the source spec - + #its deferred map doesn't travel with the copied fields. + set copyfrom [private::expand_display_fields [get_spec [dict get $at_specs -id]]] #we don't copy the @id info from the source #for now we only copy across if nothing set.. #todo - bring across defaults for empty keys at targets? @@ -3169,7 +3422,11 @@ tcl::namespace::eval punk::args { } id_info $id_info {*}{ } FORMS $F {*}{ } form_names [dict keys $F] {*}{ - } form_info $form_info {*}{ + } form_info $form_info {*}[ + # G-046: DISPLAY_DEFERRED maps inert display tokens -> {source <${...}-content> defspace dynamic } + # for display-only field content whose expansion was deferred out of parsing. + # Expanded on demand by private::expand_display_fields (empty when nothing deferred). + ] DISPLAY_DEFERRED $deferred_display {*}{ } ] @@ -3404,6 +3661,9 @@ tcl::namespace::eval punk::args { set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #G-046: resolved_def re-emits definition text from the spec - deferred display + #tokens must never leak into consumer definitions, so expand first. + set specdict [private::expand_display_fields $specdict] set opt_form [dict get $opts -form] if {[string is integer -strict $opt_form]} { @@ -4467,6 +4727,11 @@ tcl::namespace::eval punk::args { #bas ic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #G-046: specs may arrive with display-only field content deferred (parse specs + #travel in error options as -argspecs). Expand for display before rendering. + if {[tcl::dict::exists $spec_dict DISPLAY_DEFERRED] && [tcl::dict::size [tcl::dict::get $spec_dict DISPLAY_DEFERRED]]} { + set spec_dict [private::expand_display_fields $spec_dict] + } #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args @@ -4800,7 +5065,19 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $cmdhelp_display" + #align continuation lines under the first line as the table renderer's + #cell does - relative indents among continuations preserved (G-046 item 4) + set desclines [split $cmdhelp_display \n] + set labelpad [string repeat " " [string length "Description: "]] + set descjoined [lindex $desclines 0] + foreach dline [lrange $desclines 1 end] { + if {$dline eq ""} { + append descjoined \n + } else { + append descjoined \n $labelpad $dline + } + } + lappend errlines "Description: $descjoined" } incr h } @@ -4819,7 +5096,7 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Example: $example_display] } else { - lappend errlines "Example: $docurl_display" + lappend errlines "Example: $example_display" } incr h } @@ -10653,9 +10930,17 @@ tcl::namespace::eval punk::args { } tcl::dict::set $dname $argname_or_ident $existing } else { - #test: choice_multielement_clause - lset existing $element_index $chosen - tcl::dict::set $dname $argname_or_ident $existing + if {$clause_size == 1} { + #single-element clause - value in $dname is the plain (non list-wrapped) string. + #overwrite wholesale: lset would treat the scalar as a list and list-quote + #values needing quoting (backslashes/spaces) e.g {\Deleted}, giving a different + #value shape than exact input (G-046 item 3) + tcl::dict::set $dname $argname_or_ident $chosen + } else { + #test: choice_multielement_clause + lset existing $element_index $chosen + tcl::dict::set $dname $argname_or_ident $existing + } } } else { if {$is_multiple} { @@ -10965,6 +11250,7 @@ tcl::namespace::eval punk::args { if {$spec eq ""} { return } + set spec [private::expand_display_fields $spec] ;#G-046 @examples -help may be deferred if {[dict exists $spec examples_info -help]} { set egdata [dict get $spec examples_info -help] return [punk::args::helpers::strip_nodisplay_lines $egdata] @@ -11779,6 +12065,19 @@ tcl::namespace::eval punk::args { } [dict get $cinfo origin] {*}{ } ] + #id_exists only sees definitions already loaded - registered argdocs + #(::punk::args::register::NAMESPACES) load lazily, and callers such as the + #punk::ns doc-lookup path only load the ensemble command's parent namespace. + #Load the namespaces the id_checks could resolve in, or a first call before + #they are loaded (e.g 'i ' in a fresh shell) builds the definition + #without subhelp/choicelabel entries for documented subcommands. + set id_check_namespaces [list] + foreach checkid $id_checks { + set idns [namespace qualifiers $checkid] + if {$idns eq ""} {set idns ::} + if {$idns ni $id_check_namespaces} {lappend id_check_namespaces $idns} + } + punk::args::update_definitions $id_check_namespaces set N [punk::ansi::a+ normal] set RST [punk::ansi::a] foreach checkid $id_checks { @@ -13033,7 +13332,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.4.0 + set version 0.4.2 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm b/src/bootsupport/modules/punk/ns-0.1.4.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm rename to src/bootsupport/modules/punk/ns-0.1.4.tm index fbc62ce3..442d2746 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm +++ b/src/bootsupport/modules/punk/ns-0.1.4.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.3 +# Application punk::ns 0.1.4 # Meta platform tcl # Meta license # @@ Meta End @@ -5597,8 +5597,25 @@ y" {return quirkykeyscript} if {[llength $testresolved] == 1} { #only the command itself is in the args_resolved list - so we can't resolve to a deeper subcommand ledit queryargs -1 -1 {*}$args_remaining ;#prepend - if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $estyle withid $rootdoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied args + #a failure only reflects missing required leaders/values - nothing to mark and + #nothing wrong with the user's (absent) input, so we show plain usage in the + #info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the + #full usage table INSIDE the raised error only for it to be discarded here - + #doubling display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $queryargs]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $advisory_estyle withid $rootdoc} parseresult]} { + if {![llength $queryargs]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -5679,8 +5696,25 @@ y" {return quirkykeyscript} } if {$origindoc ne ""} { #important not to use "-cache 1" for this parse - need to reflect dynamically updated ensembles etc - if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied trailing args + #a failure only reflects missing required leaders/values (e.g 'i string is') - nothing + #to mark and nothing wrong with the user's (absent) input, so we show plain usage in + #the info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the full + #usage table INSIDE the raised error only for it to be discarded here - doubling + #display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $args_remaining]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $advisory_estyle withid $origindoc} parseresult]} { + if {![llength $args_remaining]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -7608,6 +7642,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.3 + set version 0.1.4 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.4.2.tm similarity index 97% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.0.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.4.2.tm index 06065b32..23ed8406 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.4.2.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.4.0 +# Application punk::args 0.4.2 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.4.0] +#[manpage_begin punkshell_module_punk::args 0 0.4.2] #[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 --}] @@ -1266,6 +1266,7 @@ tcl::namespace::eval punk::args { variable rawdef_cache_about variable id_cache_rawdef variable rawdef_cache_argdata + variable argdefcache_display if {[id_exists $id]} { if {!$quiet} { puts stderr "punk::args::undefine clearing existing data for id:$id" @@ -1274,11 +1275,13 @@ tcl::namespace::eval punk::args { set deflist [dict get $id_cache_rawdef $id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } else { dict for {k v} $rawdef_cache_argdata { if {[dict get $v id] eq $id} { dict unset rawdef_cache_argdata $k + dict unset argdefcache_display $k } } dict for {k v} $rawdef_cache_about { @@ -1314,16 +1317,390 @@ tcl::namespace::eval punk::args { proc undefine_deflist {deflist} { variable rawdef_cache_about variable id_cache_rawdef - variable rawdef_cache_argdata + variable rawdef_cache_argdata + variable argdefcache_display if {[dict exists $rawdef_cache_about $deflist -id]} { set id [dict get $rawdef_cache_about $deflist -id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } } + # -- --- --- --- --- --- --- --- --- --- --- + # G-046 display-field deferral + # Expansion of ${...} content landing in display-only fields (-help on @cmd/@examples + # and argument records, @formdisplay -header/-body) is deferred out of resolve: the + # parse spec stores inert tokens plus a DISPLAY_DEFERRED map, and display consumers + # (arg_error, eg, resolved_def) expand on demand via private::expand_display_fields. + # -choicelabels stays eager - punk::ns reads it directly from parse specs during the + # subcommand walk. + variable argdefcache_display [tcl::dict::create] ;#display-expanded specs (non-dynamic definitions), keyed by raw deflist + variable display_expanding [list] ;#definition ids currently being display-expanded (reentrancy guard) + + proc private::split_definition_records {optionspecs} { + #definition text -> list of records (factored out of resolve - G-046) + #records are delimited by newlines, but multiline values are allowed if properly + #quoted/braced - 'info complete' (on ansi-stripped accumulation) finds record ends. + set records [list] + set linebuild "" + set linelist [split $optionspecs \n] + set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. + #find the first record's base indent + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all record_base_indent + break ;#break at first non-empty + } + set in_record_continuation 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + set record_id 0 + set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record + foreach rawline $linelist { + set record_so_far [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_record [punk::ansi::ansistrip $record_so_far] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_record [string map [list \x1b\[ ""] $record_so_far] + } + if {![tcl::info::complete $test_record]} { + if {$in_record_continuation} { + #trim only the whitespace corresponding to the record indent - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + assert {$record_line == 0} punk::args::private::split_definition_records record_line + regexp {(\s*).*} $rawline _all record_base_indent + append linebuild $rawline \n + set in_record_continuation 1 + } + incr record_line + } else { + #either we're on a single line record, or last line of multiline record + if {$record_line != 0} { + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + #prep for next record + set in_record_continuation 0 + incr record_id + set record_line 0 + } + } + if {$in_record_continuation} { + puts stderr "punk::args::resolve incomplete record:" + puts stderr "$linebuild" + } + return $records + } + + proc private::classify_display_tokens {placeholdertext tokenlist} { + #G-046: return the subset of tokenlist whose tokens land in display-only field + #values. Display-only: -help on @cmd/@examples and on argument records, and + #@formdisplay -header/-body. Everything else (record names, -choices, -default, + #-choicelabels, @form -synopsis, directive settings) is parse/synopsis-relevant + #and stays eagerly expanded. + set display_tokens [list] + if {![llength $tokenlist]} { + return $display_tokens + } + set records [split_definition_records $placeholdertext] + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + if {[catch {set record_values [lassign $trimrec firstword]}]} { + continue ;#unparseable here - real errors surface in resolve's own record loop + } + if {[llength $record_values] % 2 != 0} { + continue + } + switch -glob -- $firstword { + @cmd - @examples { + set displaykeys {-help} + } + @formdisplay { + set displaykeys {-header -body} + } + @* { + set displaykeys {} + } + default { + #argument record + set displaykeys {-help} + } + } + if {![llength $displaykeys]} {continue} + foreach {k v} $record_values { + if {$k in $displaykeys && [string first \x01PADEFER $v] >= 0} { + foreach tk $tokenlist { + if {$tk ni $display_tokens && [string first $tk $v] >= 0} { + lappend display_tokens $tk + } + } + } + } + } + return $display_tokens + } + + proc private::mask_display_params {normargs defspace is_dynamic} { + #G-046 phases 0-2: extract ${...} params without evaluation (tstr -eval 0), + #classify which land in display-only fields, and return + # [list ] + #Blocks without display params are returned untouched (original text) so the + #normal tstr path processes them bit-identically. + set blockparts [list] + set tokenlist [list] + set n 0 + set phtext "" + foreach block $normargs { + if {[string first \$\{ $block] >= 0} { + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $block] ptlist paramlist + set btokens [list] + set phblock "" + set i 0 + foreach param $paramlist { + set tk [tcl::string::cat \x01 PADEFER [incr n] \x02] + append phblock [lindex $ptlist $i] $tk + lappend btokens $tk + incr i + } + append phblock [lindex $ptlist $i] + lappend blockparts [list 1 $ptlist $paramlist $btokens] + lappend tokenlist {*}$btokens + append phtext $phblock \n + } else { + lappend blockparts [list 0 {} {} {}] + append phtext $block \n + } + } + if {![llength $tokenlist]} { + return [list $normargs {}] + } + set display_tokens [classify_display_tokens $phtext $tokenlist] + if {![llength $display_tokens]} { + return [list $normargs {}] + } + set deferred [tcl::dict::create] + set outblocks [list] + foreach block $normargs bp $blockparts { + lassign $bp hasparams ptlist paramlist btokens + if {!$hasparams} { + lappend outblocks $block + continue + } + set block_display 0 + foreach tk $btokens { + if {$tk in $display_tokens} { + set block_display 1 + break + } + } + if {!$block_display} { + lappend outblocks $block + continue + } + set masked "" + set i 0 + foreach param $paramlist tk $btokens { + append masked [lindex $ptlist $i] + if {$tk in $display_tokens} { + append masked $tk + tcl::dict::set deferred $tk [tcl::dict::create source $param defspace $defspace dynamic $is_dynamic] + } else { + #parse-relevant param - reconstruct for normal tstr evaluation + append masked [tcl::string::cat \$\{ $param \}] + } + incr i + } + append masked [lindex $ptlist $i] + lappend outblocks $masked + } + return [list $outblocks $deferred] + } + + proc private::expand_display_fields {spec} { + #G-046: expand deferred display-field content of a parse spec on demand. + #Returns the spec with display fields expanded and DISPLAY_DEFERRED emptied. + #Non-dynamic expansions are cached (keyed by raw deflist); @dynamic definitions + #re-expand each call so provider changes refresh (matching resolve semantics). + if {![tcl::dict::exists $spec DISPLAY_DEFERRED]} { + return $spec + } + set map [tcl::dict::get $spec DISPLAY_DEFERRED] + if {![tcl::dict::size $map]} { + return $spec + } + set id [tcl::dict::get $spec id] + upvar ::punk::args::id_cache_rawdef id_cache_rawdef + upvar ::punk::args::rawdef_cache_about rawdef_cache_about + upvar ::punk::args::argdefcache_display argdefcache_display + set deflist "" + set spec_dynamic 0 + if {[tcl::dict::exists $id_cache_rawdef $id]} { + set deflist [tcl::dict::get $id_cache_rawdef $id] + if {[tcl::dict::exists $rawdef_cache_about $deflist -dynamic]} { + set spec_dynamic [tcl::dict::get $rawdef_cache_about $deflist -dynamic] + } + } + if {!$spec_dynamic && $deflist ne "" && [tcl::dict::exists $argdefcache_display $deflist]} { + return [tcl::dict::get $argdefcache_display $deflist] + } + upvar ::punk::args::display_expanding display_expanding + if {$id in $display_expanding} { + #reentrancy: deferred content is (indirectly) rendering help for an id whose + #display expansion is already in progress. Substitute the raw ${...} sources + #instead of evaluating - resolves cleanly, never loops. Not cached. + return [expand_display_slots $spec $map raw] + } + lappend display_expanding $id + try { + set spec [expand_display_slots $spec $map eval] + } finally { + set posn [lsearch -exact $display_expanding $id] + set display_expanding [lreplace $display_expanding $posn $posn] + } + tcl::dict::set spec DISPLAY_DEFERRED {} + if {!$spec_dynamic && $deflist ne ""} { + tcl::dict::set argdefcache_display $deflist $spec + } + return $spec + } + + proc private::expand_display_slots {spec map mode} { + #walk the display-only slots of a spec and expand deferred tokens in place + foreach infokey {cmd_info examples_info} { + if {[tcl::dict::exists $spec $infokey -help]} { + set v [tcl::dict::get $spec $infokey -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec $infokey -help [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {fid fdict} [tcl::dict::get $spec FORMS] { + if {[tcl::dict::exists $fdict FORMDISPLAY]} { + tcl::dict::for {k v} [tcl::dict::get $fdict FORMDISPLAY] { + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid FORMDISPLAY $k [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {argname arginfo} [tcl::dict::get $fdict ARG_INFO] { + if {[tcl::dict::exists $arginfo -help]} { + set v [tcl::dict::get $arginfo -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid ARG_INFO $argname -help [expand_deferred_text $v $map $mode] + } + } + } + } + return $spec + } + + proc private::expand_deferred_text {text map mode} { + #replace deferred display tokens in a field value. + #mode 'eval': substitute each token's ${...} source in its recorded definition + #namespace; @dynamic sources get the second substitution round (the ${$DYN_X} + #idiom). mode 'raw': substitute the raw ${...} source text (reentrancy path). + #Multiline results align continuation lines with the leading whitespace of the + #token's line - the same 'line' paramindents treatment punk::args::lib::tstr + #applies to eagerly expanded params (G-046 item 2 for the @dynamic path). + set out "" + set firstline 1 + foreach ln [split $text \n] { + if {!$firstline} { + append out \n + } + set firstline 0 + if {[string first \x01PADEFER $ln] < 0} { + append out $ln + continue + } + regexp {^(\s*)} $ln _all lineindent + while {[regexp -indices {\x01PADEFER[0-9]+\x02} $ln tokenposns]} { + lassign $tokenposns t0 t1 + set token [string range $ln $t0 $t1] + set replacement "" + if {[tcl::dict::exists $map $token]} { + set param [tcl::dict::get $map $token source] + set defspace [tcl::dict::get $map $token defspace] + set dynamic [tcl::dict::get $map $token dynamic] + if {$defspace eq ""} { + set defspace :: + } + if {$mode eq "raw"} { + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {[catch {tcl::namespace::eval $defspace [list ::subst $param]} presult]} { + #tstr behaviour on evaluation error: substitute the raw placeholder source + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {$dynamic && [string first \$\{ $presult] >= 0} { + #@dynamic second-round substitution + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $presult] ptlist2 paramlist2 + set r2 "" + set i 0 + foreach param2 $paramlist2 { + append r2 [lindex $ptlist2 $i] + if {[catch {tcl::namespace::eval $defspace [list ::subst $param2]} p2result]} { + append r2 [tcl::string::cat \$\{ $param2 \}] + } else { + append r2 $p2result + } + incr i + } + append r2 [lindex $ptlist2 $i] + set presult $r2 + } + set replacement $presult + } + } + } + if {$lineindent ne "" && [string first \n $replacement] >= 0} { + set rlines [split $replacement \n] + set replacement [lindex $rlines 0] + foreach rl [lrange $rlines 1 end] { + append replacement \n $lineindent $rl + } + } + set ln [string replace $ln $t0 $t1 $replacement] + } + append out $ln + } + return $out + } + # -- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { @id -id ::punk::args::resolve @cmd -name punk::args::resolve\ @@ -1403,12 +1780,14 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: -help section processing is sometimes expensive (e.g tcl syntax + #highlighted examples) and isn't required for parsing of arguments. Display-only + #${...} params are masked with inert tokens here and expanded on demand at + #display time (private::expand_display_fields) with a separate cache. + set deferred_display {} + lassign [private::mask_display_params $normargs $defspace 0] normargs deferred_display + set optionspecs [list] - #REVIEW - whilst this is only done once for each command definition, the -help section processing is sometimes expensive, - #and isn't required for parsing of arguments, so it unnecessarily slows first use of a command that uses punk::args and is heavily documented, - #especially if it has tcl syntax highlighted examples. - #- ideally we would delay expansion of -help sections until needed for display, - #and use a different cache key for the parsing vs display versions of the resolved definition. foreach block $normargs { if {[string first \$\{ $block] >= 0} { if {$defspace ne ""} { @@ -1443,10 +1822,11 @@ tcl::namespace::eval punk::args { #} } else { + set deferred_display {} if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { #cached - so first round of substitution already done set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist + lassign $pt_params ptlist paramlist deferred_display set optionspecs "" #subst is only being called on the parameters (contents of ${..}) foreach pt $ptlist param $paramlist { @@ -1463,6 +1843,11 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: mask display-only ${...} params (see non-dynamic branch note). + #Masked at round 1, so display payloads (including their round-2 + #${$DYN_X} providers) never run during argument resolution. + lassign [private::mask_display_params $normargs $defspace 1] normargs deferred_display + set optionspecs [list] foreach block $normargs { if {[string first \$\{ $block] >= 0} { @@ -1498,8 +1883,8 @@ tcl::namespace::eval punk::args { append optionspecs $pt [uplevel $LVL [list ::subst $param]] } } - #key is the raw def, value is the 2 element list of textparts, paramparts - tcl::dict::set argdefcache_unresolved $cache_key $pt_params + #key is the raw def, value is the list of textparts, paramparts (and the G-046 deferred display map) + tcl::dict::set argdefcache_unresolved $cache_key [list {*}$pt_params $deferred_display] } else { #wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required" @@ -1557,141 +1942,7 @@ tcl::namespace::eval punk::args { #set opt_solos [list] #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. - #find the first record's base indent - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all record_base_indent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $record_base_indent]" - set in_record_continuation 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - set record_id 0 - set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record - foreach rawline $linelist { - #puts stderr "$record_line $rawline" - #XXX - #set rawtrimmed [string trim $rawline] - #if {$in_record_continuation && $rawtrimmed ne "" && [string index $rawtrimmed 0] ni [list "\}" {"} "#"]} { - # regexp {(\s*).*} $rawline _ rawline_indent - # if {[string length $rawline_indent] <= [string length $record_base_indent]} { - # lappend records $linebuild - # set linebuild "" - # #prep for next record - # set in_record_continuation 0 - # incr record_id - # set record_line 0 - # } - #} - set record_so_far [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_record [punk::ansi::ansistrip $record_so_far] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_record [string map [list \x1b\[ ""] $record_so_far] - } - if {![tcl::info::complete $test_record]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record_continuation} { - #incr record_line - #if {$record_line == 1} { - # #first continuation line sets the indent - #} - - #/// - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - - #trim only the whitespace corresponding to last record indent or record_base_indent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - } else { - assert {$record_line == 0} punk::args::resolve record_line - regexp {(\s*).*} $rawline _all record_base_indent - #puts "indent: [ansistring VIEW -lf 1 $record_base_indent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - set in_record_continuation 1 - } - incr record_line - } else { - #either we're on a single line record, or last line of multiline record - - if {$record_line != 0} { - #trim only the whitespace corresponding to record_base_indent or record_base_indent + 4 spaces - not all whitespace on left - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline - #} else { - # append linebuild $rawline - #} - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - #prep for next record - set in_record_continuation 0 - incr record_id - set record_line 0 - } - } - if {$in_record_continuation} { - puts stderr "punk::args::resolve incomplete record:" - puts stderr "$linebuild" - } - #puts stderr 1[lindex $records 1] - #puts stderr 4[lindex $records 4] - #puts stderr 5[lindex $records 5] - #puts stderr 6[lindex $records 6] + set records [private::split_definition_records $optionspecs] set cmd_info {} set package_info {} @@ -1854,7 +2105,9 @@ tcl::namespace::eval punk::args { #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] + #G-046: expand any deferred display content of the source spec - + #its deferred map doesn't travel with the copied fields. + set copyfrom [private::expand_display_fields [get_spec [dict get $at_specs -id]]] #we don't copy the @id info from the source #for now we only copy across if nothing set.. #todo - bring across defaults for empty keys at targets? @@ -3169,7 +3422,11 @@ tcl::namespace::eval punk::args { } id_info $id_info {*}{ } FORMS $F {*}{ } form_names [dict keys $F] {*}{ - } form_info $form_info {*}{ + } form_info $form_info {*}[ + # G-046: DISPLAY_DEFERRED maps inert display tokens -> {source <${...}-content> defspace dynamic } + # for display-only field content whose expansion was deferred out of parsing. + # Expanded on demand by private::expand_display_fields (empty when nothing deferred). + ] DISPLAY_DEFERRED $deferred_display {*}{ } ] @@ -3404,6 +3661,9 @@ tcl::namespace::eval punk::args { set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #G-046: resolved_def re-emits definition text from the spec - deferred display + #tokens must never leak into consumer definitions, so expand first. + set specdict [private::expand_display_fields $specdict] set opt_form [dict get $opts -form] if {[string is integer -strict $opt_form]} { @@ -4467,6 +4727,11 @@ tcl::namespace::eval punk::args { #bas ic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #G-046: specs may arrive with display-only field content deferred (parse specs + #travel in error options as -argspecs). Expand for display before rendering. + if {[tcl::dict::exists $spec_dict DISPLAY_DEFERRED] && [tcl::dict::size [tcl::dict::get $spec_dict DISPLAY_DEFERRED]]} { + set spec_dict [private::expand_display_fields $spec_dict] + } #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args @@ -4800,7 +5065,19 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $cmdhelp_display" + #align continuation lines under the first line as the table renderer's + #cell does - relative indents among continuations preserved (G-046 item 4) + set desclines [split $cmdhelp_display \n] + set labelpad [string repeat " " [string length "Description: "]] + set descjoined [lindex $desclines 0] + foreach dline [lrange $desclines 1 end] { + if {$dline eq ""} { + append descjoined \n + } else { + append descjoined \n $labelpad $dline + } + } + lappend errlines "Description: $descjoined" } incr h } @@ -4819,7 +5096,7 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Example: $example_display] } else { - lappend errlines "Example: $docurl_display" + lappend errlines "Example: $example_display" } incr h } @@ -10653,9 +10930,17 @@ tcl::namespace::eval punk::args { } tcl::dict::set $dname $argname_or_ident $existing } else { - #test: choice_multielement_clause - lset existing $element_index $chosen - tcl::dict::set $dname $argname_or_ident $existing + if {$clause_size == 1} { + #single-element clause - value in $dname is the plain (non list-wrapped) string. + #overwrite wholesale: lset would treat the scalar as a list and list-quote + #values needing quoting (backslashes/spaces) e.g {\Deleted}, giving a different + #value shape than exact input (G-046 item 3) + tcl::dict::set $dname $argname_or_ident $chosen + } else { + #test: choice_multielement_clause + lset existing $element_index $chosen + tcl::dict::set $dname $argname_or_ident $existing + } } } else { if {$is_multiple} { @@ -10965,6 +11250,7 @@ tcl::namespace::eval punk::args { if {$spec eq ""} { return } + set spec [private::expand_display_fields $spec] ;#G-046 @examples -help may be deferred if {[dict exists $spec examples_info -help]} { set egdata [dict get $spec examples_info -help] return [punk::args::helpers::strip_nodisplay_lines $egdata] @@ -11779,6 +12065,19 @@ tcl::namespace::eval punk::args { } [dict get $cinfo origin] {*}{ } ] + #id_exists only sees definitions already loaded - registered argdocs + #(::punk::args::register::NAMESPACES) load lazily, and callers such as the + #punk::ns doc-lookup path only load the ensemble command's parent namespace. + #Load the namespaces the id_checks could resolve in, or a first call before + #they are loaded (e.g 'i ' in a fresh shell) builds the definition + #without subhelp/choicelabel entries for documented subcommands. + set id_check_namespaces [list] + foreach checkid $id_checks { + set idns [namespace qualifiers $checkid] + if {$idns eq ""} {set idns ::} + if {$idns ni $id_check_namespaces} {lappend id_check_namespaces $idns} + } + punk::args::update_definitions $id_check_namespaces set N [punk::ansi::a+ normal] set RST [punk::ansi::a] foreach checkid $id_checks { @@ -13033,7 +13332,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.4.0 + set version 0.4.2 }] return diff --git a/src/bootsupport/modules/punk/ns-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm similarity index 99% rename from src/bootsupport/modules/punk/ns-0.1.3.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm index fbc62ce3..442d2746 100644 --- a/src/bootsupport/modules/punk/ns-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.3 +# Application punk::ns 0.1.4 # Meta platform tcl # Meta license # @@ Meta End @@ -5597,8 +5597,25 @@ y" {return quirkykeyscript} if {[llength $testresolved] == 1} { #only the command itself is in the args_resolved list - so we can't resolve to a deeper subcommand ledit queryargs -1 -1 {*}$args_remaining ;#prepend - if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $estyle withid $rootdoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied args + #a failure only reflects missing required leaders/values - nothing to mark and + #nothing wrong with the user's (absent) input, so we show plain usage in the + #info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the + #full usage table INSIDE the raised error only for it to be discarded here - + #doubling display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $queryargs]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $advisory_estyle withid $rootdoc} parseresult]} { + if {![llength $queryargs]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -5679,8 +5696,25 @@ y" {return quirkykeyscript} } if {$origindoc ne ""} { #important not to use "-cache 1" for this parse - need to reflect dynamically updated ensembles etc - if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied trailing args + #a failure only reflects missing required leaders/values (e.g 'i string is') - nothing + #to mark and nothing wrong with the user's (absent) input, so we show plain usage in + #the info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the full + #usage table INSIDE the raised error only for it to be discarded here - doubling + #display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $args_remaining]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $advisory_estyle withid $origindoc} parseresult]} { + if {![llength $args_remaining]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -7608,6 +7642,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.3 + set version 0.1.4 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.4.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.2.tm similarity index 97% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.4.0.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.2.tm index 06065b32..23ed8406 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.4.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.4.2.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.4.0 +# Application punk::args 0.4.2 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.4.0] +#[manpage_begin punkshell_module_punk::args 0 0.4.2] #[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 --}] @@ -1266,6 +1266,7 @@ tcl::namespace::eval punk::args { variable rawdef_cache_about variable id_cache_rawdef variable rawdef_cache_argdata + variable argdefcache_display if {[id_exists $id]} { if {!$quiet} { puts stderr "punk::args::undefine clearing existing data for id:$id" @@ -1274,11 +1275,13 @@ tcl::namespace::eval punk::args { set deflist [dict get $id_cache_rawdef $id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } else { dict for {k v} $rawdef_cache_argdata { if {[dict get $v id] eq $id} { dict unset rawdef_cache_argdata $k + dict unset argdefcache_display $k } } dict for {k v} $rawdef_cache_about { @@ -1314,16 +1317,390 @@ tcl::namespace::eval punk::args { proc undefine_deflist {deflist} { variable rawdef_cache_about variable id_cache_rawdef - variable rawdef_cache_argdata + variable rawdef_cache_argdata + variable argdefcache_display if {[dict exists $rawdef_cache_about $deflist -id]} { set id [dict get $rawdef_cache_about $deflist -id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } } + # -- --- --- --- --- --- --- --- --- --- --- + # G-046 display-field deferral + # Expansion of ${...} content landing in display-only fields (-help on @cmd/@examples + # and argument records, @formdisplay -header/-body) is deferred out of resolve: the + # parse spec stores inert tokens plus a DISPLAY_DEFERRED map, and display consumers + # (arg_error, eg, resolved_def) expand on demand via private::expand_display_fields. + # -choicelabels stays eager - punk::ns reads it directly from parse specs during the + # subcommand walk. + variable argdefcache_display [tcl::dict::create] ;#display-expanded specs (non-dynamic definitions), keyed by raw deflist + variable display_expanding [list] ;#definition ids currently being display-expanded (reentrancy guard) + + proc private::split_definition_records {optionspecs} { + #definition text -> list of records (factored out of resolve - G-046) + #records are delimited by newlines, but multiline values are allowed if properly + #quoted/braced - 'info complete' (on ansi-stripped accumulation) finds record ends. + set records [list] + set linebuild "" + set linelist [split $optionspecs \n] + set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. + #find the first record's base indent + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all record_base_indent + break ;#break at first non-empty + } + set in_record_continuation 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + set record_id 0 + set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record + foreach rawline $linelist { + set record_so_far [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_record [punk::ansi::ansistrip $record_so_far] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_record [string map [list \x1b\[ ""] $record_so_far] + } + if {![tcl::info::complete $test_record]} { + if {$in_record_continuation} { + #trim only the whitespace corresponding to the record indent - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + assert {$record_line == 0} punk::args::private::split_definition_records record_line + regexp {(\s*).*} $rawline _all record_base_indent + append linebuild $rawline \n + set in_record_continuation 1 + } + incr record_line + } else { + #either we're on a single line record, or last line of multiline record + if {$record_line != 0} { + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + #prep for next record + set in_record_continuation 0 + incr record_id + set record_line 0 + } + } + if {$in_record_continuation} { + puts stderr "punk::args::resolve incomplete record:" + puts stderr "$linebuild" + } + return $records + } + + proc private::classify_display_tokens {placeholdertext tokenlist} { + #G-046: return the subset of tokenlist whose tokens land in display-only field + #values. Display-only: -help on @cmd/@examples and on argument records, and + #@formdisplay -header/-body. Everything else (record names, -choices, -default, + #-choicelabels, @form -synopsis, directive settings) is parse/synopsis-relevant + #and stays eagerly expanded. + set display_tokens [list] + if {![llength $tokenlist]} { + return $display_tokens + } + set records [split_definition_records $placeholdertext] + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + if {[catch {set record_values [lassign $trimrec firstword]}]} { + continue ;#unparseable here - real errors surface in resolve's own record loop + } + if {[llength $record_values] % 2 != 0} { + continue + } + switch -glob -- $firstword { + @cmd - @examples { + set displaykeys {-help} + } + @formdisplay { + set displaykeys {-header -body} + } + @* { + set displaykeys {} + } + default { + #argument record + set displaykeys {-help} + } + } + if {![llength $displaykeys]} {continue} + foreach {k v} $record_values { + if {$k in $displaykeys && [string first \x01PADEFER $v] >= 0} { + foreach tk $tokenlist { + if {$tk ni $display_tokens && [string first $tk $v] >= 0} { + lappend display_tokens $tk + } + } + } + } + } + return $display_tokens + } + + proc private::mask_display_params {normargs defspace is_dynamic} { + #G-046 phases 0-2: extract ${...} params without evaluation (tstr -eval 0), + #classify which land in display-only fields, and return + # [list ] + #Blocks without display params are returned untouched (original text) so the + #normal tstr path processes them bit-identically. + set blockparts [list] + set tokenlist [list] + set n 0 + set phtext "" + foreach block $normargs { + if {[string first \$\{ $block] >= 0} { + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $block] ptlist paramlist + set btokens [list] + set phblock "" + set i 0 + foreach param $paramlist { + set tk [tcl::string::cat \x01 PADEFER [incr n] \x02] + append phblock [lindex $ptlist $i] $tk + lappend btokens $tk + incr i + } + append phblock [lindex $ptlist $i] + lappend blockparts [list 1 $ptlist $paramlist $btokens] + lappend tokenlist {*}$btokens + append phtext $phblock \n + } else { + lappend blockparts [list 0 {} {} {}] + append phtext $block \n + } + } + if {![llength $tokenlist]} { + return [list $normargs {}] + } + set display_tokens [classify_display_tokens $phtext $tokenlist] + if {![llength $display_tokens]} { + return [list $normargs {}] + } + set deferred [tcl::dict::create] + set outblocks [list] + foreach block $normargs bp $blockparts { + lassign $bp hasparams ptlist paramlist btokens + if {!$hasparams} { + lappend outblocks $block + continue + } + set block_display 0 + foreach tk $btokens { + if {$tk in $display_tokens} { + set block_display 1 + break + } + } + if {!$block_display} { + lappend outblocks $block + continue + } + set masked "" + set i 0 + foreach param $paramlist tk $btokens { + append masked [lindex $ptlist $i] + if {$tk in $display_tokens} { + append masked $tk + tcl::dict::set deferred $tk [tcl::dict::create source $param defspace $defspace dynamic $is_dynamic] + } else { + #parse-relevant param - reconstruct for normal tstr evaluation + append masked [tcl::string::cat \$\{ $param \}] + } + incr i + } + append masked [lindex $ptlist $i] + lappend outblocks $masked + } + return [list $outblocks $deferred] + } + + proc private::expand_display_fields {spec} { + #G-046: expand deferred display-field content of a parse spec on demand. + #Returns the spec with display fields expanded and DISPLAY_DEFERRED emptied. + #Non-dynamic expansions are cached (keyed by raw deflist); @dynamic definitions + #re-expand each call so provider changes refresh (matching resolve semantics). + if {![tcl::dict::exists $spec DISPLAY_DEFERRED]} { + return $spec + } + set map [tcl::dict::get $spec DISPLAY_DEFERRED] + if {![tcl::dict::size $map]} { + return $spec + } + set id [tcl::dict::get $spec id] + upvar ::punk::args::id_cache_rawdef id_cache_rawdef + upvar ::punk::args::rawdef_cache_about rawdef_cache_about + upvar ::punk::args::argdefcache_display argdefcache_display + set deflist "" + set spec_dynamic 0 + if {[tcl::dict::exists $id_cache_rawdef $id]} { + set deflist [tcl::dict::get $id_cache_rawdef $id] + if {[tcl::dict::exists $rawdef_cache_about $deflist -dynamic]} { + set spec_dynamic [tcl::dict::get $rawdef_cache_about $deflist -dynamic] + } + } + if {!$spec_dynamic && $deflist ne "" && [tcl::dict::exists $argdefcache_display $deflist]} { + return [tcl::dict::get $argdefcache_display $deflist] + } + upvar ::punk::args::display_expanding display_expanding + if {$id in $display_expanding} { + #reentrancy: deferred content is (indirectly) rendering help for an id whose + #display expansion is already in progress. Substitute the raw ${...} sources + #instead of evaluating - resolves cleanly, never loops. Not cached. + return [expand_display_slots $spec $map raw] + } + lappend display_expanding $id + try { + set spec [expand_display_slots $spec $map eval] + } finally { + set posn [lsearch -exact $display_expanding $id] + set display_expanding [lreplace $display_expanding $posn $posn] + } + tcl::dict::set spec DISPLAY_DEFERRED {} + if {!$spec_dynamic && $deflist ne ""} { + tcl::dict::set argdefcache_display $deflist $spec + } + return $spec + } + + proc private::expand_display_slots {spec map mode} { + #walk the display-only slots of a spec and expand deferred tokens in place + foreach infokey {cmd_info examples_info} { + if {[tcl::dict::exists $spec $infokey -help]} { + set v [tcl::dict::get $spec $infokey -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec $infokey -help [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {fid fdict} [tcl::dict::get $spec FORMS] { + if {[tcl::dict::exists $fdict FORMDISPLAY]} { + tcl::dict::for {k v} [tcl::dict::get $fdict FORMDISPLAY] { + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid FORMDISPLAY $k [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {argname arginfo} [tcl::dict::get $fdict ARG_INFO] { + if {[tcl::dict::exists $arginfo -help]} { + set v [tcl::dict::get $arginfo -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid ARG_INFO $argname -help [expand_deferred_text $v $map $mode] + } + } + } + } + return $spec + } + + proc private::expand_deferred_text {text map mode} { + #replace deferred display tokens in a field value. + #mode 'eval': substitute each token's ${...} source in its recorded definition + #namespace; @dynamic sources get the second substitution round (the ${$DYN_X} + #idiom). mode 'raw': substitute the raw ${...} source text (reentrancy path). + #Multiline results align continuation lines with the leading whitespace of the + #token's line - the same 'line' paramindents treatment punk::args::lib::tstr + #applies to eagerly expanded params (G-046 item 2 for the @dynamic path). + set out "" + set firstline 1 + foreach ln [split $text \n] { + if {!$firstline} { + append out \n + } + set firstline 0 + if {[string first \x01PADEFER $ln] < 0} { + append out $ln + continue + } + regexp {^(\s*)} $ln _all lineindent + while {[regexp -indices {\x01PADEFER[0-9]+\x02} $ln tokenposns]} { + lassign $tokenposns t0 t1 + set token [string range $ln $t0 $t1] + set replacement "" + if {[tcl::dict::exists $map $token]} { + set param [tcl::dict::get $map $token source] + set defspace [tcl::dict::get $map $token defspace] + set dynamic [tcl::dict::get $map $token dynamic] + if {$defspace eq ""} { + set defspace :: + } + if {$mode eq "raw"} { + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {[catch {tcl::namespace::eval $defspace [list ::subst $param]} presult]} { + #tstr behaviour on evaluation error: substitute the raw placeholder source + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {$dynamic && [string first \$\{ $presult] >= 0} { + #@dynamic second-round substitution + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $presult] ptlist2 paramlist2 + set r2 "" + set i 0 + foreach param2 $paramlist2 { + append r2 [lindex $ptlist2 $i] + if {[catch {tcl::namespace::eval $defspace [list ::subst $param2]} p2result]} { + append r2 [tcl::string::cat \$\{ $param2 \}] + } else { + append r2 $p2result + } + incr i + } + append r2 [lindex $ptlist2 $i] + set presult $r2 + } + set replacement $presult + } + } + } + if {$lineindent ne "" && [string first \n $replacement] >= 0} { + set rlines [split $replacement \n] + set replacement [lindex $rlines 0] + foreach rl [lrange $rlines 1 end] { + append replacement \n $lineindent $rl + } + } + set ln [string replace $ln $t0 $t1 $replacement] + } + append out $ln + } + return $out + } + # -- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { @id -id ::punk::args::resolve @cmd -name punk::args::resolve\ @@ -1403,12 +1780,14 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: -help section processing is sometimes expensive (e.g tcl syntax + #highlighted examples) and isn't required for parsing of arguments. Display-only + #${...} params are masked with inert tokens here and expanded on demand at + #display time (private::expand_display_fields) with a separate cache. + set deferred_display {} + lassign [private::mask_display_params $normargs $defspace 0] normargs deferred_display + set optionspecs [list] - #REVIEW - whilst this is only done once for each command definition, the -help section processing is sometimes expensive, - #and isn't required for parsing of arguments, so it unnecessarily slows first use of a command that uses punk::args and is heavily documented, - #especially if it has tcl syntax highlighted examples. - #- ideally we would delay expansion of -help sections until needed for display, - #and use a different cache key for the parsing vs display versions of the resolved definition. foreach block $normargs { if {[string first \$\{ $block] >= 0} { if {$defspace ne ""} { @@ -1443,10 +1822,11 @@ tcl::namespace::eval punk::args { #} } else { + set deferred_display {} if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { #cached - so first round of substitution already done set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist + lassign $pt_params ptlist paramlist deferred_display set optionspecs "" #subst is only being called on the parameters (contents of ${..}) foreach pt $ptlist param $paramlist { @@ -1463,6 +1843,11 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: mask display-only ${...} params (see non-dynamic branch note). + #Masked at round 1, so display payloads (including their round-2 + #${$DYN_X} providers) never run during argument resolution. + lassign [private::mask_display_params $normargs $defspace 1] normargs deferred_display + set optionspecs [list] foreach block $normargs { if {[string first \$\{ $block] >= 0} { @@ -1498,8 +1883,8 @@ tcl::namespace::eval punk::args { append optionspecs $pt [uplevel $LVL [list ::subst $param]] } } - #key is the raw def, value is the 2 element list of textparts, paramparts - tcl::dict::set argdefcache_unresolved $cache_key $pt_params + #key is the raw def, value is the list of textparts, paramparts (and the G-046 deferred display map) + tcl::dict::set argdefcache_unresolved $cache_key [list {*}$pt_params $deferred_display] } else { #wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required" @@ -1557,141 +1942,7 @@ tcl::namespace::eval punk::args { #set opt_solos [list] #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. - #find the first record's base indent - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all record_base_indent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $record_base_indent]" - set in_record_continuation 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - set record_id 0 - set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record - foreach rawline $linelist { - #puts stderr "$record_line $rawline" - #XXX - #set rawtrimmed [string trim $rawline] - #if {$in_record_continuation && $rawtrimmed ne "" && [string index $rawtrimmed 0] ni [list "\}" {"} "#"]} { - # regexp {(\s*).*} $rawline _ rawline_indent - # if {[string length $rawline_indent] <= [string length $record_base_indent]} { - # lappend records $linebuild - # set linebuild "" - # #prep for next record - # set in_record_continuation 0 - # incr record_id - # set record_line 0 - # } - #} - set record_so_far [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_record [punk::ansi::ansistrip $record_so_far] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_record [string map [list \x1b\[ ""] $record_so_far] - } - if {![tcl::info::complete $test_record]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record_continuation} { - #incr record_line - #if {$record_line == 1} { - # #first continuation line sets the indent - #} - - #/// - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - - #trim only the whitespace corresponding to last record indent or record_base_indent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - } else { - assert {$record_line == 0} punk::args::resolve record_line - regexp {(\s*).*} $rawline _all record_base_indent - #puts "indent: [ansistring VIEW -lf 1 $record_base_indent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - set in_record_continuation 1 - } - incr record_line - } else { - #either we're on a single line record, or last line of multiline record - - if {$record_line != 0} { - #trim only the whitespace corresponding to record_base_indent or record_base_indent + 4 spaces - not all whitespace on left - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline - #} else { - # append linebuild $rawline - #} - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - #prep for next record - set in_record_continuation 0 - incr record_id - set record_line 0 - } - } - if {$in_record_continuation} { - puts stderr "punk::args::resolve incomplete record:" - puts stderr "$linebuild" - } - #puts stderr 1[lindex $records 1] - #puts stderr 4[lindex $records 4] - #puts stderr 5[lindex $records 5] - #puts stderr 6[lindex $records 6] + set records [private::split_definition_records $optionspecs] set cmd_info {} set package_info {} @@ -1854,7 +2105,9 @@ tcl::namespace::eval punk::args { #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] + #G-046: expand any deferred display content of the source spec - + #its deferred map doesn't travel with the copied fields. + set copyfrom [private::expand_display_fields [get_spec [dict get $at_specs -id]]] #we don't copy the @id info from the source #for now we only copy across if nothing set.. #todo - bring across defaults for empty keys at targets? @@ -3169,7 +3422,11 @@ tcl::namespace::eval punk::args { } id_info $id_info {*}{ } FORMS $F {*}{ } form_names [dict keys $F] {*}{ - } form_info $form_info {*}{ + } form_info $form_info {*}[ + # G-046: DISPLAY_DEFERRED maps inert display tokens -> {source <${...}-content> defspace dynamic } + # for display-only field content whose expansion was deferred out of parsing. + # Expanded on demand by private::expand_display_fields (empty when nothing deferred). + ] DISPLAY_DEFERRED $deferred_display {*}{ } ] @@ -3404,6 +3661,9 @@ tcl::namespace::eval punk::args { set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #G-046: resolved_def re-emits definition text from the spec - deferred display + #tokens must never leak into consumer definitions, so expand first. + set specdict [private::expand_display_fields $specdict] set opt_form [dict get $opts -form] if {[string is integer -strict $opt_form]} { @@ -4467,6 +4727,11 @@ tcl::namespace::eval punk::args { #bas ic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #G-046: specs may arrive with display-only field content deferred (parse specs + #travel in error options as -argspecs). Expand for display before rendering. + if {[tcl::dict::exists $spec_dict DISPLAY_DEFERRED] && [tcl::dict::size [tcl::dict::get $spec_dict DISPLAY_DEFERRED]]} { + set spec_dict [private::expand_display_fields $spec_dict] + } #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args @@ -4800,7 +5065,19 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $cmdhelp_display" + #align continuation lines under the first line as the table renderer's + #cell does - relative indents among continuations preserved (G-046 item 4) + set desclines [split $cmdhelp_display \n] + set labelpad [string repeat " " [string length "Description: "]] + set descjoined [lindex $desclines 0] + foreach dline [lrange $desclines 1 end] { + if {$dline eq ""} { + append descjoined \n + } else { + append descjoined \n $labelpad $dline + } + } + lappend errlines "Description: $descjoined" } incr h } @@ -4819,7 +5096,7 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Example: $example_display] } else { - lappend errlines "Example: $docurl_display" + lappend errlines "Example: $example_display" } incr h } @@ -10653,9 +10930,17 @@ tcl::namespace::eval punk::args { } tcl::dict::set $dname $argname_or_ident $existing } else { - #test: choice_multielement_clause - lset existing $element_index $chosen - tcl::dict::set $dname $argname_or_ident $existing + if {$clause_size == 1} { + #single-element clause - value in $dname is the plain (non list-wrapped) string. + #overwrite wholesale: lset would treat the scalar as a list and list-quote + #values needing quoting (backslashes/spaces) e.g {\Deleted}, giving a different + #value shape than exact input (G-046 item 3) + tcl::dict::set $dname $argname_or_ident $chosen + } else { + #test: choice_multielement_clause + lset existing $element_index $chosen + tcl::dict::set $dname $argname_or_ident $existing + } } } else { if {$is_multiple} { @@ -10965,6 +11250,7 @@ tcl::namespace::eval punk::args { if {$spec eq ""} { return } + set spec [private::expand_display_fields $spec] ;#G-046 @examples -help may be deferred if {[dict exists $spec examples_info -help]} { set egdata [dict get $spec examples_info -help] return [punk::args::helpers::strip_nodisplay_lines $egdata] @@ -11779,6 +12065,19 @@ tcl::namespace::eval punk::args { } [dict get $cinfo origin] {*}{ } ] + #id_exists only sees definitions already loaded - registered argdocs + #(::punk::args::register::NAMESPACES) load lazily, and callers such as the + #punk::ns doc-lookup path only load the ensemble command's parent namespace. + #Load the namespaces the id_checks could resolve in, or a first call before + #they are loaded (e.g 'i ' in a fresh shell) builds the definition + #without subhelp/choicelabel entries for documented subcommands. + set id_check_namespaces [list] + foreach checkid $id_checks { + set idns [namespace qualifiers $checkid] + if {$idns eq ""} {set idns ::} + if {$idns ni $id_check_namespaces} {lappend id_check_namespaces $idns} + } + punk::args::update_definitions $id_check_namespaces set N [punk::ansi::a+ normal] set RST [punk::ansi::a] foreach checkid $id_checks { @@ -13033,7 +13332,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.4.0 + set version 0.4.2 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.3.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm index fbc62ce3..442d2746 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.4.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.3 +# Application punk::ns 0.1.4 # Meta platform tcl # Meta license # @@ Meta End @@ -5597,8 +5597,25 @@ y" {return quirkykeyscript} if {[llength $testresolved] == 1} { #only the command itself is in the args_resolved list - so we can't resolve to a deeper subcommand ledit queryargs -1 -1 {*}$args_remaining ;#prepend - if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $estyle withid $rootdoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied args + #a failure only reflects missing required leaders/values - nothing to mark and + #nothing wrong with the user's (absent) input, so we show plain usage in the + #info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the + #full usage table INSIDE the raised error only for it to be discarded here - + #doubling display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $queryargs]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $advisory_estyle withid $rootdoc} parseresult]} { + if {![llength $queryargs]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -5679,8 +5696,25 @@ y" {return quirkykeyscript} } if {$origindoc ne ""} { #important not to use "-cache 1" for this parse - need to reflect dynamically updated ensembles etc - if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied trailing args + #a failure only reflects missing required leaders/values (e.g 'i string is') - nothing + #to mark and nothing wrong with the user's (absent) input, so we show plain usage in + #the info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the full + #usage table INSIDE the raised error only for it to be discarded here - doubling + #display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $args_remaining]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $advisory_estyle withid $origindoc} parseresult]} { + if {![llength $args_remaining]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -7608,6 +7642,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.3 + set version 0.1.4 }] return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.4.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.4.2.tm similarity index 97% rename from src/vfs/_vfscommon.vfs/modules/punk/args-0.4.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args-0.4.2.tm index 06065b32..23ed8406 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.4.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.4.2.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.4.0 +# Application punk::args 0.4.2 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.4.0] +#[manpage_begin punkshell_module_punk::args 0 0.4.2] #[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 --}] @@ -1266,6 +1266,7 @@ tcl::namespace::eval punk::args { variable rawdef_cache_about variable id_cache_rawdef variable rawdef_cache_argdata + variable argdefcache_display if {[id_exists $id]} { if {!$quiet} { puts stderr "punk::args::undefine clearing existing data for id:$id" @@ -1274,11 +1275,13 @@ tcl::namespace::eval punk::args { set deflist [dict get $id_cache_rawdef $id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } else { dict for {k v} $rawdef_cache_argdata { if {[dict get $v id] eq $id} { dict unset rawdef_cache_argdata $k + dict unset argdefcache_display $k } } dict for {k v} $rawdef_cache_about { @@ -1314,16 +1317,390 @@ tcl::namespace::eval punk::args { proc undefine_deflist {deflist} { variable rawdef_cache_about variable id_cache_rawdef - variable rawdef_cache_argdata + variable rawdef_cache_argdata + variable argdefcache_display if {[dict exists $rawdef_cache_about $deflist -id]} { set id [dict get $rawdef_cache_about $deflist -id] dict unset rawdef_cache_about $deflist dict unset rawdef_cache_argdata $deflist + dict unset argdefcache_display $deflist dict unset id_cache_rawdef $id } } + # -- --- --- --- --- --- --- --- --- --- --- + # G-046 display-field deferral + # Expansion of ${...} content landing in display-only fields (-help on @cmd/@examples + # and argument records, @formdisplay -header/-body) is deferred out of resolve: the + # parse spec stores inert tokens plus a DISPLAY_DEFERRED map, and display consumers + # (arg_error, eg, resolved_def) expand on demand via private::expand_display_fields. + # -choicelabels stays eager - punk::ns reads it directly from parse specs during the + # subcommand walk. + variable argdefcache_display [tcl::dict::create] ;#display-expanded specs (non-dynamic definitions), keyed by raw deflist + variable display_expanding [list] ;#definition ids currently being display-expanded (reentrancy guard) + + proc private::split_definition_records {optionspecs} { + #definition text -> list of records (factored out of resolve - G-046) + #records are delimited by newlines, but multiline values are allowed if properly + #quoted/braced - 'info complete' (on ansi-stripped accumulation) finds record ends. + set records [list] + set linebuild "" + set linelist [split $optionspecs \n] + set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. + #find the first record's base indent + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all record_base_indent + break ;#break at first non-empty + } + set in_record_continuation 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + set record_id 0 + set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record + foreach rawline $linelist { + set record_so_far [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_record [punk::ansi::ansistrip $record_so_far] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_record [string map [list \x1b\[ ""] $record_so_far] + } + if {![tcl::info::complete $test_record]} { + if {$in_record_continuation} { + #trim only the whitespace corresponding to the record indent - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + assert {$record_line == 0} punk::args::private::split_definition_records record_line + regexp {(\s*).*} $rawline _all record_base_indent + append linebuild $rawline \n + set in_record_continuation 1 + } + incr record_line + } else { + #either we're on a single line record, or last line of multiline record + if {$record_line != 0} { + if {[tcl::string::first $record_base_indent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + #prep for next record + set in_record_continuation 0 + incr record_id + set record_line 0 + } + } + if {$in_record_continuation} { + puts stderr "punk::args::resolve incomplete record:" + puts stderr "$linebuild" + } + return $records + } + + proc private::classify_display_tokens {placeholdertext tokenlist} { + #G-046: return the subset of tokenlist whose tokens land in display-only field + #values. Display-only: -help on @cmd/@examples and on argument records, and + #@formdisplay -header/-body. Everything else (record names, -choices, -default, + #-choicelabels, @form -synopsis, directive settings) is parse/synopsis-relevant + #and stays eagerly expanded. + set display_tokens [list] + if {![llength $tokenlist]} { + return $display_tokens + } + set records [split_definition_records $placeholdertext] + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + if {[catch {set record_values [lassign $trimrec firstword]}]} { + continue ;#unparseable here - real errors surface in resolve's own record loop + } + if {[llength $record_values] % 2 != 0} { + continue + } + switch -glob -- $firstword { + @cmd - @examples { + set displaykeys {-help} + } + @formdisplay { + set displaykeys {-header -body} + } + @* { + set displaykeys {} + } + default { + #argument record + set displaykeys {-help} + } + } + if {![llength $displaykeys]} {continue} + foreach {k v} $record_values { + if {$k in $displaykeys && [string first \x01PADEFER $v] >= 0} { + foreach tk $tokenlist { + if {$tk ni $display_tokens && [string first $tk $v] >= 0} { + lappend display_tokens $tk + } + } + } + } + } + return $display_tokens + } + + proc private::mask_display_params {normargs defspace is_dynamic} { + #G-046 phases 0-2: extract ${...} params without evaluation (tstr -eval 0), + #classify which land in display-only fields, and return + # [list ] + #Blocks without display params are returned untouched (original text) so the + #normal tstr path processes them bit-identically. + set blockparts [list] + set tokenlist [list] + set n 0 + set phtext "" + foreach block $normargs { + if {[string first \$\{ $block] >= 0} { + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $block] ptlist paramlist + set btokens [list] + set phblock "" + set i 0 + foreach param $paramlist { + set tk [tcl::string::cat \x01 PADEFER [incr n] \x02] + append phblock [lindex $ptlist $i] $tk + lappend btokens $tk + incr i + } + append phblock [lindex $ptlist $i] + lappend blockparts [list 1 $ptlist $paramlist $btokens] + lappend tokenlist {*}$btokens + append phtext $phblock \n + } else { + lappend blockparts [list 0 {} {} {}] + append phtext $block \n + } + } + if {![llength $tokenlist]} { + return [list $normargs {}] + } + set display_tokens [classify_display_tokens $phtext $tokenlist] + if {![llength $display_tokens]} { + return [list $normargs {}] + } + set deferred [tcl::dict::create] + set outblocks [list] + foreach block $normargs bp $blockparts { + lassign $bp hasparams ptlist paramlist btokens + if {!$hasparams} { + lappend outblocks $block + continue + } + set block_display 0 + foreach tk $btokens { + if {$tk in $display_tokens} { + set block_display 1 + break + } + } + if {!$block_display} { + lappend outblocks $block + continue + } + set masked "" + set i 0 + foreach param $paramlist tk $btokens { + append masked [lindex $ptlist $i] + if {$tk in $display_tokens} { + append masked $tk + tcl::dict::set deferred $tk [tcl::dict::create source $param defspace $defspace dynamic $is_dynamic] + } else { + #parse-relevant param - reconstruct for normal tstr evaluation + append masked [tcl::string::cat \$\{ $param \}] + } + incr i + } + append masked [lindex $ptlist $i] + lappend outblocks $masked + } + return [list $outblocks $deferred] + } + + proc private::expand_display_fields {spec} { + #G-046: expand deferred display-field content of a parse spec on demand. + #Returns the spec with display fields expanded and DISPLAY_DEFERRED emptied. + #Non-dynamic expansions are cached (keyed by raw deflist); @dynamic definitions + #re-expand each call so provider changes refresh (matching resolve semantics). + if {![tcl::dict::exists $spec DISPLAY_DEFERRED]} { + return $spec + } + set map [tcl::dict::get $spec DISPLAY_DEFERRED] + if {![tcl::dict::size $map]} { + return $spec + } + set id [tcl::dict::get $spec id] + upvar ::punk::args::id_cache_rawdef id_cache_rawdef + upvar ::punk::args::rawdef_cache_about rawdef_cache_about + upvar ::punk::args::argdefcache_display argdefcache_display + set deflist "" + set spec_dynamic 0 + if {[tcl::dict::exists $id_cache_rawdef $id]} { + set deflist [tcl::dict::get $id_cache_rawdef $id] + if {[tcl::dict::exists $rawdef_cache_about $deflist -dynamic]} { + set spec_dynamic [tcl::dict::get $rawdef_cache_about $deflist -dynamic] + } + } + if {!$spec_dynamic && $deflist ne "" && [tcl::dict::exists $argdefcache_display $deflist]} { + return [tcl::dict::get $argdefcache_display $deflist] + } + upvar ::punk::args::display_expanding display_expanding + if {$id in $display_expanding} { + #reentrancy: deferred content is (indirectly) rendering help for an id whose + #display expansion is already in progress. Substitute the raw ${...} sources + #instead of evaluating - resolves cleanly, never loops. Not cached. + return [expand_display_slots $spec $map raw] + } + lappend display_expanding $id + try { + set spec [expand_display_slots $spec $map eval] + } finally { + set posn [lsearch -exact $display_expanding $id] + set display_expanding [lreplace $display_expanding $posn $posn] + } + tcl::dict::set spec DISPLAY_DEFERRED {} + if {!$spec_dynamic && $deflist ne ""} { + tcl::dict::set argdefcache_display $deflist $spec + } + return $spec + } + + proc private::expand_display_slots {spec map mode} { + #walk the display-only slots of a spec and expand deferred tokens in place + foreach infokey {cmd_info examples_info} { + if {[tcl::dict::exists $spec $infokey -help]} { + set v [tcl::dict::get $spec $infokey -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec $infokey -help [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {fid fdict} [tcl::dict::get $spec FORMS] { + if {[tcl::dict::exists $fdict FORMDISPLAY]} { + tcl::dict::for {k v} [tcl::dict::get $fdict FORMDISPLAY] { + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid FORMDISPLAY $k [expand_deferred_text $v $map $mode] + } + } + } + tcl::dict::for {argname arginfo} [tcl::dict::get $fdict ARG_INFO] { + if {[tcl::dict::exists $arginfo -help]} { + set v [tcl::dict::get $arginfo -help] + if {[string first \x01PADEFER $v] >= 0} { + tcl::dict::set spec FORMS $fid ARG_INFO $argname -help [expand_deferred_text $v $map $mode] + } + } + } + } + return $spec + } + + proc private::expand_deferred_text {text map mode} { + #replace deferred display tokens in a field value. + #mode 'eval': substitute each token's ${...} source in its recorded definition + #namespace; @dynamic sources get the second substitution round (the ${$DYN_X} + #idiom). mode 'raw': substitute the raw ${...} source text (reentrancy path). + #Multiline results align continuation lines with the leading whitespace of the + #token's line - the same 'line' paramindents treatment punk::args::lib::tstr + #applies to eagerly expanded params (G-046 item 2 for the @dynamic path). + set out "" + set firstline 1 + foreach ln [split $text \n] { + if {!$firstline} { + append out \n + } + set firstline 0 + if {[string first \x01PADEFER $ln] < 0} { + append out $ln + continue + } + regexp {^(\s*)} $ln _all lineindent + while {[regexp -indices {\x01PADEFER[0-9]+\x02} $ln tokenposns]} { + lassign $tokenposns t0 t1 + set token [string range $ln $t0 $t1] + set replacement "" + if {[tcl::dict::exists $map $token]} { + set param [tcl::dict::get $map $token source] + set defspace [tcl::dict::get $map $token defspace] + set dynamic [tcl::dict::get $map $token dynamic] + if {$defspace eq ""} { + set defspace :: + } + if {$mode eq "raw"} { + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {[catch {tcl::namespace::eval $defspace [list ::subst $param]} presult]} { + #tstr behaviour on evaluation error: substitute the raw placeholder source + set replacement [tcl::string::cat \$\{ $param \}] + } else { + if {$dynamic && [string first \$\{ $presult] >= 0} { + #@dynamic second-round substitution + lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $presult] ptlist2 paramlist2 + set r2 "" + set i 0 + foreach param2 $paramlist2 { + append r2 [lindex $ptlist2 $i] + if {[catch {tcl::namespace::eval $defspace [list ::subst $param2]} p2result]} { + append r2 [tcl::string::cat \$\{ $param2 \}] + } else { + append r2 $p2result + } + incr i + } + append r2 [lindex $ptlist2 $i] + set presult $r2 + } + set replacement $presult + } + } + } + if {$lineindent ne "" && [string first \n $replacement] >= 0} { + set rlines [split $replacement \n] + set replacement [lindex $rlines 0] + foreach rl [lrange $rlines 1 end] { + append replacement \n $lineindent $rl + } + } + set ln [string replace $ln $t0 $t1 $replacement] + } + append out $ln + } + return $out + } + # -- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { @id -id ::punk::args::resolve @cmd -name punk::args::resolve\ @@ -1403,12 +1780,14 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: -help section processing is sometimes expensive (e.g tcl syntax + #highlighted examples) and isn't required for parsing of arguments. Display-only + #${...} params are masked with inert tokens here and expanded on demand at + #display time (private::expand_display_fields) with a separate cache. + set deferred_display {} + lassign [private::mask_display_params $normargs $defspace 0] normargs deferred_display + set optionspecs [list] - #REVIEW - whilst this is only done once for each command definition, the -help section processing is sometimes expensive, - #and isn't required for parsing of arguments, so it unnecessarily slows first use of a command that uses punk::args and is heavily documented, - #especially if it has tcl syntax highlighted examples. - #- ideally we would delay expansion of -help sections until needed for display, - #and use a different cache key for the parsing vs display versions of the resolved definition. foreach block $normargs { if {[string first \$\{ $block] >= 0} { if {$defspace ne ""} { @@ -1443,10 +1822,11 @@ tcl::namespace::eval punk::args { #} } else { + set deferred_display {} if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { #cached - so first round of substitution already done set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist + lassign $pt_params ptlist paramlist deferred_display set optionspecs "" #subst is only being called on the parameters (contents of ${..}) foreach pt $ptlist param $paramlist { @@ -1463,6 +1843,11 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } + #G-046: mask display-only ${...} params (see non-dynamic branch note). + #Masked at round 1, so display payloads (including their round-2 + #${$DYN_X} providers) never run during argument resolution. + lassign [private::mask_display_params $normargs $defspace 1] normargs deferred_display + set optionspecs [list] foreach block $normargs { if {[string first \$\{ $block] >= 0} { @@ -1498,8 +1883,8 @@ tcl::namespace::eval punk::args { append optionspecs $pt [uplevel $LVL [list ::subst $param]] } } - #key is the raw def, value is the 2 element list of textparts, paramparts - tcl::dict::set argdefcache_unresolved $cache_key $pt_params + #key is the raw def, value is the list of textparts, paramparts (and the G-046 deferred display map) + tcl::dict::set argdefcache_unresolved $cache_key [list {*}$pt_params $deferred_display] } else { #wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required" @@ -1557,141 +1942,7 @@ tcl::namespace::eval punk::args { #set opt_solos [list] #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented. - #find the first record's base indent - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all record_base_indent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $record_base_indent]" - set in_record_continuation 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - set record_id 0 - set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record - foreach rawline $linelist { - #puts stderr "$record_line $rawline" - #XXX - #set rawtrimmed [string trim $rawline] - #if {$in_record_continuation && $rawtrimmed ne "" && [string index $rawtrimmed 0] ni [list "\}" {"} "#"]} { - # regexp {(\s*).*} $rawline _ rawline_indent - # if {[string length $rawline_indent] <= [string length $record_base_indent]} { - # lappend records $linebuild - # set linebuild "" - # #prep for next record - # set in_record_continuation 0 - # incr record_id - # set record_line 0 - # } - #} - set record_so_far [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_record [punk::ansi::ansistrip $record_so_far] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_record [string map [list \x1b\[ ""] $record_so_far] - } - if {![tcl::info::complete $test_record]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record_continuation} { - #incr record_line - #if {$record_line == 1} { - # #first continuation line sets the indent - #} - - #/// - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - - #trim only the whitespace corresponding to last record indent or record_base_indent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline \n - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline \n - #} else { - # append linebuild $rawline \n - #} - } else { - assert {$record_line == 0} punk::args::resolve record_line - regexp {(\s*).*} $rawline _all record_base_indent - #puts "indent: [ansistring VIEW -lf 1 $record_base_indent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - set in_record_continuation 1 - } - incr record_line - } else { - #either we're on a single line record, or last line of multiline record - - if {$record_line != 0} { - #trim only the whitespace corresponding to record_base_indent or record_base_indent + 4 spaces - not all whitespace on left - #if {[tcl::string::first "$record_base_indent " $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length "$record_base_indent "] end] - # append linebuild $trimmedline - #} elseif {[tcl::string::first $record_base_indent $rawline] == 0} { - # set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - # append linebuild $trimmedline - #} else { - # append linebuild $rawline - #} - if {[tcl::string::first $record_base_indent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - #prep for next record - set in_record_continuation 0 - incr record_id - set record_line 0 - } - } - if {$in_record_continuation} { - puts stderr "punk::args::resolve incomplete record:" - puts stderr "$linebuild" - } - #puts stderr 1[lindex $records 1] - #puts stderr 4[lindex $records 4] - #puts stderr 5[lindex $records 5] - #puts stderr 6[lindex $records 6] + set records [private::split_definition_records $optionspecs] set cmd_info {} set package_info {} @@ -1854,7 +2105,9 @@ tcl::namespace::eval punk::args { #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] + #G-046: expand any deferred display content of the source spec - + #its deferred map doesn't travel with the copied fields. + set copyfrom [private::expand_display_fields [get_spec [dict get $at_specs -id]]] #we don't copy the @id info from the source #for now we only copy across if nothing set.. #todo - bring across defaults for empty keys at targets? @@ -3169,7 +3422,11 @@ tcl::namespace::eval punk::args { } id_info $id_info {*}{ } FORMS $F {*}{ } form_names [dict keys $F] {*}{ - } form_info $form_info {*}{ + } form_info $form_info {*}[ + # G-046: DISPLAY_DEFERRED maps inert display tokens -> {source <${...}-content> defspace dynamic } + # for display-only field content whose expansion was deferred out of parsing. + # Expanded on demand by private::expand_display_fields (empty when nothing deferred). + ] DISPLAY_DEFERRED $deferred_display {*}{ } ] @@ -3404,6 +3661,9 @@ tcl::namespace::eval punk::args { set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #G-046: resolved_def re-emits definition text from the spec - deferred display + #tokens must never leak into consumer definitions, so expand first. + set specdict [private::expand_display_fields $specdict] set opt_form [dict get $opts -form] if {[string is integer -strict $opt_form]} { @@ -4467,6 +4727,11 @@ tcl::namespace::eval punk::args { #bas ic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #G-046: specs may arrive with display-only field content deferred (parse specs + #travel in error options as -argspecs). Expand for display before rendering. + if {[tcl::dict::exists $spec_dict DISPLAY_DEFERRED] && [tcl::dict::size [tcl::dict::get $spec_dict DISPLAY_DEFERRED]]} { + set spec_dict [private::expand_display_fields $spec_dict] + } #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args @@ -4800,7 +5065,19 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $cmdhelp_display" + #align continuation lines under the first line as the table renderer's + #cell does - relative indents among continuations preserved (G-046 item 4) + set desclines [split $cmdhelp_display \n] + set labelpad [string repeat " " [string length "Description: "]] + set descjoined [lindex $desclines 0] + foreach dline [lrange $desclines 1 end] { + if {$dline eq ""} { + append descjoined \n + } else { + append descjoined \n $labelpad $dline + } + } + lappend errlines "Description: $descjoined" } incr h } @@ -4819,7 +5096,7 @@ tcl::namespace::eval punk::args { if {$use_table} { $t configure_header $h -colspans $arg_colspans -values [list Example: $example_display] } else { - lappend errlines "Example: $docurl_display" + lappend errlines "Example: $example_display" } incr h } @@ -10653,9 +10930,17 @@ tcl::namespace::eval punk::args { } tcl::dict::set $dname $argname_or_ident $existing } else { - #test: choice_multielement_clause - lset existing $element_index $chosen - tcl::dict::set $dname $argname_or_ident $existing + if {$clause_size == 1} { + #single-element clause - value in $dname is the plain (non list-wrapped) string. + #overwrite wholesale: lset would treat the scalar as a list and list-quote + #values needing quoting (backslashes/spaces) e.g {\Deleted}, giving a different + #value shape than exact input (G-046 item 3) + tcl::dict::set $dname $argname_or_ident $chosen + } else { + #test: choice_multielement_clause + lset existing $element_index $chosen + tcl::dict::set $dname $argname_or_ident $existing + } } } else { if {$is_multiple} { @@ -10965,6 +11250,7 @@ tcl::namespace::eval punk::args { if {$spec eq ""} { return } + set spec [private::expand_display_fields $spec] ;#G-046 @examples -help may be deferred if {[dict exists $spec examples_info -help]} { set egdata [dict get $spec examples_info -help] return [punk::args::helpers::strip_nodisplay_lines $egdata] @@ -11779,6 +12065,19 @@ tcl::namespace::eval punk::args { } [dict get $cinfo origin] {*}{ } ] + #id_exists only sees definitions already loaded - registered argdocs + #(::punk::args::register::NAMESPACES) load lazily, and callers such as the + #punk::ns doc-lookup path only load the ensemble command's parent namespace. + #Load the namespaces the id_checks could resolve in, or a first call before + #they are loaded (e.g 'i ' in a fresh shell) builds the definition + #without subhelp/choicelabel entries for documented subcommands. + set id_check_namespaces [list] + foreach checkid $id_checks { + set idns [namespace qualifiers $checkid] + if {$idns eq ""} {set idns ::} + if {$idns ni $id_check_namespaces} {lappend id_check_namespaces $idns} + } + punk::args::update_definitions $id_check_namespaces set N [punk::ansi::a+ normal] set RST [punk::ansi::a] foreach checkid $id_checks { @@ -13033,7 +13332,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.4.0 + set version 0.4.2 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.4.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm rename to src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.4.tm index fbc62ce3..442d2746 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.4.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.3 +# Application punk::ns 0.1.4 # Meta platform tcl # Meta license # @@ Meta End @@ -5597,8 +5597,25 @@ y" {return quirkykeyscript} if {[llength $testresolved] == 1} { #only the command itself is in the args_resolved list - so we can't resolve to a deeper subcommand ledit queryargs -1 -1 {*}$args_remaining ;#prepend - if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $estyle withid $rootdoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied args + #a failure only reflects missing required leaders/values - nothing to mark and + #nothing wrong with the user's (absent) input, so we show plain usage in the + #info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the + #full usage table INSIDE the raised error only for it to be discarded here - + #doubling display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $queryargs]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $advisory_estyle withid $rootdoc} parseresult]} { + if {![llength $queryargs]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -5679,8 +5696,25 @@ y" {return quirkykeyscript} } if {$origindoc ne ""} { #important not to use "-cache 1" for this parse - need to reflect dynamically updated ensembles etc - if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { - if {$opt_return eq "tableobject"} { + #advisory goodargs parse (marking of supplied words). With NO supplied trailing args + #a failure only reflects missing required leaders/values (e.g 'i string is') - nothing + #to mark and nothing wrong with the user's (absent) input, so we show plain usage in + #the info scheme instead of the internal-looking parse error (G-046 item 5). + #Use -errorstyle minimal for that case: the $estyle rendering would build the full + #usage table INSIDE the raised error only for it to be discarded here - doubling + #display time for large argdocs (e.g 'i punk::args::define'). + if {![llength $args_remaining]} { + set advisory_estyle minimal + } else { + set advisory_estyle $estyle + } + if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $advisory_estyle withid $origindoc} parseresult]} { + if {![llength $args_remaining]} { + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] + } elseif {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { set result $parseresult @@ -7608,6 +7642,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.3 + set version 0.1.4 }] return \ No newline at end of file