@ -270,6 +270,190 @@ tcl::namespace::eval punk::args::register {
tcl::namespace::eval ::punk::args {}
tcl::namespace::eval ::punk::args::helpers {
variable PUNKARGS
namespace export *
#proc B {} {return \x1b\[1m} ;#a+ bold
#proc N {} {return \x1b\[22m} ;#a+ normal
#proc I {} {return \x1b\[3m} ;#a+ italic
#proc NI {} {return \x1b\[23m} ;#a+ noitalic
proc I {} {punk::ansi::a+ italic}
proc B {} {punk::ansi::a+ bold}
proc N {} {punk::ansi::a+ normal}
proc NI {} {punk::ansi::a+ italic}
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::example
@cmd -name punk::args::helpers::example\
-summary\
{Display formatting for argdoc example text}\
-help\
{Wrap }
@opts
-padright -type integer -default 2 -help\
{Number of padding spaces to add on RHS of text block}
-syntax -type string -default tcl -choices {none tcl} -choicelabels {
tcl\
" Very basic tcl syntax highlighting
of braces,square brackets and comments."
-title -type string -default ""
-titlealign -type string -choices {left centre right}
}
text -type string
}]
proc example {args} {
#only use punk::args::parse on the unhappy path
if {[llength $args] == 0} {
punk::args::parse $args withid ::punk::args::helpers::example
return
}
set str [lindex $args end]
set optlist [lrange $args 0 end-1]
if {[llength $optlist] %2 != 0} {
punk::args::parse $args withid ::punk::args::helpers::example
return
}
set defaults [dict create\
-padright 2\
-syntax tcl\
-title ""\
-titlealign left\
]
dict for {o v} $optlist {
switch -- $o {
-padright - -syntax - -title - -titlealign {}
default {
punk::args::parse $args withid ::punk::args::helpers::example
return
}
}
}
set opts [dict merge $defaults $optlist]
set opt_padright [dict get $opts -padright]
set opt_syntax [dict get $opts -syntax]
set opt_title [dict get $opts -title]
set opt_titlealign [dict get $opts -titlealign]
if {[string index $str 0] eq "\n"} {
set str [string range $str 1 end]
}
if {[string index $str end] eq "\n"} {
set str [string range $str 0 end-1]
}
#example is intended to run from a source doc that has already been dedented appropriately based on context
# - we don't want to further undent, hence -undent 0
set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
if {$opt_padright > 0} {
set str [textblock::join -- $str [string repeat " " $opt_padright]]
}
if {$opt_title ne ""} {
set title "[a+ term-black Term-silver]$opt_title[a]"
} else {
set title ""
}
set str [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [a+ Term-grey white] -ansiborder [a+ term-black Term-silver] -titlealign $opt_titlealign -title $title -boxlimits {hl} -type block $str]]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
#rudimentary colourising (not full tcl syntax parsing)
#highlight comments first - so that we can also highlight braces within comments to help with detecting unbalanced braces/square brackets in comments
switch -- $opt_syntax {
tcl {
#result lines often indicated in examples by \u2192 →
#however - it's not present on each line of output, instead indents are used - so we can't so easily highlight all appropriate rows(?)
set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {^\s*#.*} $str] ;#Note, will not highlight comments at end of line - like this one
set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {;\s*(#.*)} $str]
#TODO - fix grepstr highlighting (bg issues - why?)
set str [punk::grepstr -return all -highlight {Term-grey term-darkblue} {\{|\}} $str]
set str [punk::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
}
}
set result [textblock::bookend_lines $str [a] "[a defaultbg] [a]"]
return $result
}
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::strip_nodisplay_lines
@cmd -name punk::args::helpers::strip_nodisplay_lines\
-summary\
"strip #<nodisplay> lines."\
-help\
"Strip lines beginning with #<nodisplay> from the supplied text.
Whitespace prior to #<nodisplay> is ignored, and ANSI is stripped
prior to examining each line for the #<nodisplay> tag."
@values -min 1 -max 1
text -optional 0 -help\
{punk::args::define scripts must have properly balanced braces etc
as per Tcl rules.
Sometimes it is desired to display help text or examples demonstrating
unbalanced braces etc, but without escaping it in a way that shows the
escaping backslash in the help text. This balancing requirement includes
curly braces in comments. eg
${[punk::args::helpers::example -title " Example 1a " {
proc bad_syntax {args} {
#eg this is an unbalanced left curly brace {
#<nodisplay> balancing right curly brace }
return $args
}
}]}
There is a second comment line in the above proc which begins
with #<nodisplay> and contains the balancing right curly brace.
This shouldn't show in the example above.
The actual text is in a placeholder call to punk::args::helpers::example
to provide basic syntax highlighting and box background, and looks like
the following, but without the left-hand side pipe symbols.
${[punk::args::helpers::example -syntax none -title " Example 1b " {
| proc bad_syntax {args} {
| #eg this is an unbalanced left curly brace {
| #<nodisplay> balancing right curly brace }
| return $args
| }
}]}
Technically a proc body can exist with an unbalanced brace in a comment
like that and would still run without issue. However, such a definition
couldn't be placed in a tcl file to be sourced, nor directly evaluated
with eval.
A #<nodisplay> comment can also be used just for commenting the help
source inline.
Note that an opening square bracket can't be balanced by a line beginning
with the # character.
The non-comment form @#<nodisplay> is available so help lines beginning
with this token will also be stripped. This can be used to 'close' a
section of text that happens to look like a command block. This should
only be used if there is some reason the opening square bracket can't
be rewritten in the help doc to be escaped with a backslash.
The ${[B]}strip_nodisplay_lines${[N]} function is called automatically
by the help text generators in punk::args, and generally shouldn't need
to be used directly, but nevertheless resides in in punk::args::helpers
alongside the ${[B]}example${[N]} function which is intended for writers
of punk::args::define scripts (command documentors) to use.
}
}]
proc strip_nodisplay_lines {text} {
set display ""
foreach ln [split $text \n] {
set stripped [string trimleft [punk::ansi::ansistrip $ln]]
if {![string match "#<nodisplay>*" $stripped] && ![string match "@#<nodisplay>*" $stripped]} {
append display $ln \n
}
}
if {[string index $display end] eq "\n"} {
set display [string range $display 0 end-1]
}
return $display
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -419,6 +603,7 @@ tcl::namespace::eval punk::args {
directive-options: -help <str>
%B%@seealso%N% ?opt val...?
directive-options: -name <str> -url <str> (for footer - unimplemented)
%B%@instance%N% ?opt val...?
Some other options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults
@ -624,8 +809,21 @@ tcl::namespace::eval punk::args {
-maxsize (type dependant)
-range (type dependant - only valid if -type is a single item)
-typeranges (list with same number of elements as -type)
-help <string>
for the @cmd directive - this is the main multiline description.
For an argument is the multi-line help that displays in the Help
column.
For the @examples directive this is the text for examples as
displayed with 'eg <commandname>'
The -help string can be delimited with double quotes or with
curly braces, the choice will affect what inner chars require
backslash escaping - but neither type of help block is
automatically subject to variable or command substitution aside
from those specifically wrapped in placeholders.
For cases where unbalanced braces, double quotes are to
be displayed to the user without visible backslash escapes,
see 'i ::punk::args::helpers::strip_nodisplay_lines'
"
-dynamic -type boolean -default 0 -help\
"If -dynamic is true, tstr interpolations of the form \$\{\$var\}
@ -649,7 +847,7 @@ tcl::namespace::eval punk::args {
from existing definitions (by id) for re-use of argument specifications and help text)
e.g the following definition passes 2 blocks as text arguments
${[punk::args::moduledoc::tclcore::argdoc ::example {
${[punk::args::helpers ::example {
punk::args::define {
@id -id ::myns::myfunc
@cmd -name myns::myfunc -help\
@ -955,6 +1153,8 @@ tcl::namespace::eval punk::args {
set LVL 2
if {!$is_dynamic} {
#todo - don't use cached version if 'colour off' vs 'colour on' different to when last resolved!
#(e.g example blocks will still have colour if previously resolved)
if {[tcl::dict::exists $argdata_cache $cache_key]} {
return [tcl::dict::get $argdata_cache $cache_key]
}
@ -965,7 +1165,7 @@ tcl::namespace::eval punk::args {
set optionspecs [list]
foreach block $normargs {
if {[string first \$\{ $block] > 0} {
if {[string first \$\{ $block] >= 0} {
if {$defspace ne ""} {
set block [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]]
} else {
@ -1082,6 +1282,19 @@ tcl::namespace::eval punk::args {
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.
@ -1174,6 +1387,10 @@ tcl::namespace::eval punk::args {
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]
@ -1185,6 +1402,8 @@ tcl::namespace::eval punk::args {
set doc_info {}
#set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table
set seealso_info {}
#set credits_info {} ;#e.g see interp man CREDITS section todo - where to display?
set instance_info {}
set keywords_info {}
set examples_info {}
###set leader_min 0
@ -1212,6 +1431,14 @@ tcl::namespace::eval punk::args {
"" - # {continue}
}
incr record_number
if {[catch {lassign $trimrec firstword}]} {
puts stdout "----------------------------------------------"
puts stderr "rec: $rec"
set ::testrecord $rec
puts stdout "----------------------------------------------"
puts "records: $records"
puts stdout "=============================================="
}
set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict
if {[llength $record_values] % 2 != 0} {
#todo - avoid raising an error - store invalid defs keyed on id
@ -1854,6 +2081,10 @@ tcl::namespace::eval punk::args {
#like @doc, except displays in footer, multiple - sub-table?
set seealso_info [dict merge $seealso_info $at_specs]
}
instance {
#todo!
set instance_info [dict merge $instance_info $at_specs]
}
keywords {
#review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ??
set keywords_info [dict merge $keywords_info $at_specs]
@ -2429,6 +2660,7 @@ tcl::namespace::eval punk::args {
doc_info $doc_info\
package_info $package_info\
seealso_info $seealso_info\
instance_info $instance_info\
keywords_info $keywords_info\
examples_info $examples_info\
id_info $id_info\
@ -2461,9 +2693,9 @@ tcl::namespace::eval punk::args {
namespace eval argdoc {
variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @examples @formdisplay @seealso @leaders @opts @values leaders opts values}
variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @examples @formdisplay @seealso @instance @ leaders @opts @values leaders opts values}
variable resolved_def_TYPE_CHOICEGROUPS {
directives {@id @package @cmd @ref @doc @examples @formdisplay @seealso}
directives {@id @package @cmd @ref @doc @examples @formdisplay @seealso @instance }
argumenttypes {leaders opts values}
remaining_defaults {@leaders @opts @values}
}
@ -2680,7 +2912,7 @@ tcl::namespace::eval punk::args {
dict set resultdict @id [list -id [dict get $specdict id]]
}
}
foreach directive {@package @cmd @doc @examples @seealso} {
foreach directive {@package @cmd @doc @examples @seealso @instance } {
set dshort [string range $directive 1 end]
if {"$directive" in $included_directives} {
if {[dict exists $opt_override $directive]} {
@ -2747,7 +2979,7 @@ tcl::namespace::eval punk::args {
}
}
}
@package - @cmd - @doc - @examples - @seealso {
@package - @cmd - @doc - @examples - @seealso - @instance {
if {"$type" in $included_directives} {
set tp [string range $type 1 end] ;# @package -> package
if {[dict exists $opt_override $type]} {
@ -3671,6 +3903,7 @@ tcl::namespace::eval punk::args {
lappend blank_header_col ""
#set cmdhelp_display [a+ brightwhite]$cmdhelp[a]
#set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)]
set cmdhelp [punk::args::helpers::strip_nodisplay_lines $cmdhelp]
set cmdhelp_display [punk::ansi::ansiwrap_raw $CLR(linebase_header) "" "" $cmdhelp]
} else {
set cmdhelp_display ""
@ -4055,6 +4288,7 @@ tcl::namespace::eval punk::args {
}
set unindentedfields [Dict_getdef $arginfo -unindentedfields {}]
set help [Dict_getdef $arginfo -help ""]
set help [punk::args::helpers::strip_nodisplay_lines $help]
set allchoices_originalcase [list]
set choices [Dict_getdef $arginfo -choices {}]
set choicegroups [Dict_getdef $arginfo -choicegroups {}]
@ -4610,7 +4844,6 @@ tcl::namespace::eval punk::args {
Will usually match the command name"
}]
proc usage {args} {
#lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received
lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received
set id [dict get $values id]
set real_id [real_id $id]
@ -4656,7 +4889,7 @@ tcl::namespace::eval punk::args {
lappend PUNKARGS [list {
@id -id ::punk::args::parse
@cmd -name punk::args::parse -help\
" parse and validate command arguments based on a definition.
{ parse and validate command arguments based on a definition.
In the 'withid' form the definition is a pre-existing record that has been
created with ::punk::args::define, or indirectly by adding a definition to
@ -4673,6 +4906,7 @@ tcl::namespace::eval punk::args {
Returns a dict of information regarding the parsed arguments
example of basic usage for single option only:
${[punk::args::helpers::example {
punk::args::define {
@id -id ::myns::myfunc
@cmd -name myns::myfunc
@ -4687,9 +4921,10 @@ tcl::namespace::eval punk::args {
set argd [punk::args::parse $args withid ::myns::myfunc]
lassign [dict values $argd] leaders opts values received solos
if {[dict exists $received] -configfile} {
puts \ "have option for existing file [dict get $opts -configfile]\ "
puts "have option for existing file [dict get $opts -configfile]"
}
}
}]}
The leaders, opts, values keys in the parse result dict are proper dicts.
The received key is dict-like but can have repeated keys for arguments than can
accept multiples. The value for each received element is the ordinal position.
@ -4698,7 +4933,7 @@ tcl::namespace::eval punk::args {
to another procedure which also requires solos, because the opts dict contains
solo flags with a 1 value or a list of 1's if it was a solo with -multiple true
specified.
"
}
@form -form {withid withdef}
@leaders -min 1 -max 1
arglist -type list -optional 0 -help\
@ -4713,6 +4948,12 @@ tcl::namespace::eval punk::args {
#default to enhanced errorstyle despite slow 'catch' (unhappy path) performance
#todo - configurable per interp/namespace
-errorstyle -type string -default enhanced -choices {enhanced standard basic minimal}
-cache -type boolean -default 0 -help\
{Use sparingly.
This uses a cache for same arguments being parsed against
the same definition.
It is a minor speedup suitable for when a small set of similar
(and generally small) arguments are repeatedly used by a function.}
@values -min 2
@ -4738,6 +4979,7 @@ tcl::namespace::eval punk::args {
how to process the definition."
}]
variable parse_cache [dict create]
proc parse {args} {
#puts "punk::args::parse --> '$args'"
set tailtype "" ;#withid|withdef
@ -4802,6 +5044,7 @@ tcl::namespace::eval punk::args {
set defaultopts [dict create\
-form {*}\
-errorstyle standard\
-cache 0\
]
#todo - load override_errorstyle from configuration
@ -4810,7 +5053,7 @@ tcl::namespace::eval punk::args {
set opts [dict merge $defaultopts $opts]
dict for {k v} $opts {
switch -- $k {
-form - -errorstyle {
-form - -errorstyle - -cache {
}
default {
#punk::args::usage $args withid ::punk::args::parse ??
@ -4847,7 +5090,19 @@ tcl::namespace::eval punk::args {
}
try {
#puts stdout "parse --> get_dict <deflist> $parseargs -form [dict get $opts -form]"
if {![dict get $opts -cache]} {
set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]]
} else {
variable parse_cache
set key [list $parseargs $deflist [dict get $opts -form]]
if {[dict exists $parse_cache $key]} {
set result [dict get $parse_cache $key]
} else {
set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]]
dict set parse_cache $key $result
}
return $result
}
} trap {PUNKARGS VALIDATION} {msg erroropts} {
set opt_errorstyle [dict get $opts -errorstyle]
@ -7201,7 +7456,7 @@ tcl::namespace::eval punk::args {
# -----------------------------------------------
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc)
tcl::dict::with argspecs {} ;#turn keys into vars
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info, id_info,form_names
# -----------------------------------------------
set opt_form [dict get $proc_opts -form]
if {$opt_form eq "*"} {
@ -9152,7 +9407,8 @@ tcl::namespace::eval punk::args {
return
}
if {[dict exists $spec examples_info -help]} {
return [dict get $spec examples_info -help]
set egdata [dict get $spec examples_info -help]
return [punk::args::helpers::strip_nodisplay_lines $egdata]
} else {
return "no @examples defined for $id"
}
@ -9177,7 +9433,8 @@ tcl::namespace::eval punk::args {
cmditem -multiple 1 -optional 0
}]
proc synopsis {args} {
set argd [punk::args::parse $args withid ::punk::args::synopsis]
#synopsis potentially called repeatedly with same args? use -cache 1
set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis]
if {[catch {package require punk::ansi} errM]} {
set has_punkansi 0
@ -10807,7 +11064,7 @@ tcl::namespace::eval punk::args::package {
# set PUNKARGS ""
#}
lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package
lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package ::punk::args::helpers
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
