From 25ed96003cad85cfa448a6fa7136a671cf0e0416 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sun, 30 Jun 2024 01:59:24 +1000 Subject: [PATCH] punk::lib::tstr template literals, punk pipeline and pdict fixes, misc fixes --- .../#tarjar-loadscript-tarjar.tcl | 4 +- src/modules/punk-0.1.tm | 1962 +++++++++++------ src/modules/punk/aliascore-999999.0a1.0.tm | 107 +- src/modules/punk/ansi-999999.0a1.0.tm | 43 +- src/modules/punk/args-999999.0a1.0.tm | 82 +- src/modules/punk/basictelnet-999999.0a1.0.tm | 3 +- src/modules/punk/console-999999.0a1.0.tm | 1 - src/modules/punk/fileline-999999.0a1.0.tm | 7 +- src/modules/punk/lib-999999.0a1.0.tm | 578 ++++- src/modules/punk/ns-999999.0a1.0.tm | 37 +- src/modules/punk/repl-0.1.tm | 11 +- src/modules/textblock-999999.0a1.0.tm | 518 +++-- 12 files changed, 2362 insertions(+), 991 deletions(-) diff --git a/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl b/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl index 57927403..8cf897d0 100644 --- a/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl +++ b/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl @@ -2210,11 +2210,11 @@ if {[file exists $tarjar]} { proc tarjar::_::make_sfx_zip { zipfile outfile sfx_stub } { set in [open $zipfile r] - fconfigure $in -translation binary -encoding binary + fconfigure $in -translation binary -encoding iso8859-1 #set in_data [read $in [file size $zipfile]] set out [open $outfile w+] - fconfigure $out -translation binary -encoding binary + fconfigure $out -translation binary -encoding iso8859-1 puts -nonewline $out $sfx_stub diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 7e5bb479..52126362 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -71,18 +71,43 @@ set punk_testd [dict create \ ] \ e0 "multi\nline"\ ] +#test dict 2 - uniform structure and some keys with common prefixes for glob matching +set punk_testd2 [dict create \ + a0 [dict create \ + b1 {a b c}\ + b2 {a b c d}\ + x1 {x y z 1 2}\ + y2 {X Y Z 1 2}\ + z1 {k1 v1 k2 v2 k3 v3}\ + ] \ + a1 [dict create \ + b1 {a b c}\ + b2 {a b c d}\ + x1 {x y z 1 2}\ + y2 {X Y Z 1 2}\ + z1 {k1 v1 k2 v2 k3 v3}\ + ] \ + b1 [dict create \ + b1 {a b c}\ + b2 {a b c d}\ + x1 {x y z 1 2}\ + y2 {X Y Z 1 2}\ + z1 {k1 v1 k2 v2 k3 v3}\ + ] \ +] #impolitely cooperative withe punk repl - todo - tone it down. #namespace eval ::punk::repl::codethread { # variable running 0 #} package require punk::lib +package require punk::ansi +#require aliascore after punk::lib & punk::ansi are loaded package require punk::aliascore ;#mostly punk::lib aliases punk::aliascore::init package require punk::repl::codethread package require punk::config -package require punk::ansi #package require textblock if {![llength [info commands ::ansistring]]} { namespace import punk::ansi::ansistring @@ -488,7 +513,7 @@ namespace eval punk { } set varlist [list] - set var_terminals [list "@" "/" "#" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) + set var_terminals [list "@" "/" "#" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) #except when prefixed directly by pin classifier ^ set protect_terminals [list "^"] ;# e.g sequence ^# #also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string @@ -573,7 +598,7 @@ namespace eval punk { } proc _split_var_key_at_unbracketed_comma {varspecs} { set varlist [list] - set var_terminals [list "@" "/" "#"] + set var_terminals [list "@" "/" "#" "!"] #except when prefixed directly by pin classifier ^ set protect_terminals [list "^"] ;# e.g sequence ^# #also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string @@ -640,7 +665,7 @@ namespace eval punk { } proc _split_var_key_at_unbracketed_comma1 {varspecs} { set varlist [list] - set var_terminals [list "@" "/" "#"] + set var_terminals [list "@" "/" "#" "!"] set in_brackets 0 #set varspecs [string trimleft $varspecs ,] set token "" @@ -706,7 +731,8 @@ namespace eval punk { } proc destructure {selector data} { - #puts stderr ".d." + # replaced by proc generating destructure_func - + puts stderr "punk::destructure .d. selector:'$selector'" set selector [string trim $selector /] upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position @@ -729,7 +755,7 @@ namespace eval punk { set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. #todo - see if 'string is list' improved in tcl9 vs catch {llength $list} - switch -- $index { + switch -exact -- $index { # { set active_key_type "list" if {![catch {llength $leveldata} assigned]} { @@ -775,96 +801,89 @@ namespace eval punk { set assigned [lindex $leveldata $index] set already_assigned 1 } + @@ - @?@ - @??@ { + set active_key_type "dict" + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + # + #set subpath [join [lrange $subindices 0 $i_keyindex] /] + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set next_this_level [incr v_dict_idx($subpath)] + set keyindex [expr {$next_this_level -1}] + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + if {$index eq "@?@"} { + set assigned [dict get $leveldata $k] + } else { + set assigned [list $k [dict get $leveldata $k]] + } + } else { + if {$index eq "@@"} { + set action ?mismatch-dict-index-out-of-range + break + } else { + set assigned [list] + } + } + set already_assigned 1 + } default { - switch -exact -- $index { - @@ - @?@ - @??@ { + switch -glob -- $index { + @@* { set active_key_type "dict" - - #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc - #x@@ = a {x y} - #x@@/@0 = a - #x@@/@1 = x y - #x@@/a = a {x y} - # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. - # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) - # It is analogous to v1@,v2@ for lists. - # @pairs is more useful for repeated operations - - # - #set subpath [join [lrange $subindices 0 $i_keyindex] /] - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict + set key [string range $index 2 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set action ?mismatch-dict-key-not-found break } - set next_this_level [incr v_dict_idx($subpath)] - set keyindex [expr {$next_this_level -1}] - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - if {$index eq "@?@"} { - set assigned [dict get $leveldata $k] - } else { - set assigned [list $k [dict get $leveldata $k]] - } + set already_assigned 1 + } + {@\?@*} { + set active_key_type "dict" + set key [string range $index 3 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] } else { - if {$index eq "@@"} { - set action ?mismatch-dict-index-out-of-range - break - } else { - set assigned [list] - } + set assigned [list] } set already_assigned 1 } - default { - switch -glob -- $index { - @@* { - set active_key_type "dict" - set key [string range $index 2 end] - #dict exists test is safe - no need for catch - if {[dict exists $leveldata $key]} { - set assigned [dict get $leveldata $key] - } else { - set action ?mismatch-dict-key-not-found - break - } - set already_assigned 1 - } - {@\?@*} { - set active_key_type "dict" - set key [string range $index 3 end] - #dict exists test is safe - no need for catch - if {[dict exists $leveldata $key]} { - set assigned [dict get $leveldata $key] - } else { - set assigned [list] - } - set already_assigned 1 - } - {@\?\?@*} { - set active_key_type "dict" - set key [string range $index 4 end] - #dict exists test is safe - no need for catch - if {[dict exists $leveldata $key]} { - set assigned [list $key [dict get $leveldata $key]] - } else { - set assigned [list] - } - set already_assigned 1 - } - @* { - set active_key_type "list" - set do_bounds_check 1 - set index [string trimleft $index @] - } - default { - # - } - + {@\?\?@*} { + set active_key_type "dict" + set key [string range $index 4 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [list $key [dict get $leveldata $key]] + } else { + set assigned [list] } + set already_assigned 1 + } + @* { + set active_key_type "list" + set do_bounds_check 1 + set index [string trimleft $index @] + } + default { + # } - } - if {!$already_assigned} { if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { @@ -929,6 +948,7 @@ namespace eval punk { #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax set assigned [lindex $leveldata 0] } elseif {$index eq "end"} { + # @end /end if {[catch {llength $leveldata} len]} { set action ?mismatch-not-a-list break @@ -952,6 +972,7 @@ namespace eval punk { } set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. } elseif {$index eq "anyhead"} { + # @anyhead #allow returning of head or nothing if empty list if {[catch {llength $leveldata} len]} { set action ?mismatch-not-a-list @@ -959,6 +980,7 @@ namespace eval punk { } set assigned [lindex $leveldata 0] } elseif {$index eq "anytail"} { + # @anytail #allow returning of tail or nothing if empty list #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. if {[catch {llength $leveldata} len]} { @@ -967,6 +989,7 @@ namespace eval punk { } set assigned [lrange $leveldata 1 end] } elseif {$index eq "init"} { + # @init #all but last element - same as haskell 'init' if {[catch {llength $leveldata} len]} { set action ?mismatch-not-a-list @@ -974,6 +997,7 @@ namespace eval punk { } set assigned [lrange $leveldata 0 end-1] } elseif {$index eq "list"} { + # @list #allow returning of entire list even if empty if {[catch {llength $leveldata} len]} { set action ?mismatch-not-a-list @@ -1083,6 +1107,7 @@ namespace eval punk { error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } } elseif {[string first - $index] > 0} { + puts "====> index:$index leveldata:$leveldata" if {[catch {llength $leveldata} len]} { set action ?mismatch-not-a-list break @@ -1140,7 +1165,7 @@ namespace eval punk { return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] } - #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a tcl script + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script proc destructure_func {selector data} { #puts stderr ".d." set selector [string trim $selector /] @@ -1148,35 +1173,76 @@ namespace eval punk { #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position set leveldata $data - set cmdname ::punk::pipecmds::destructure_$selector + #map some problematic things out of the way in a manner that maintains some transparency + #The selector forms part of the proc name + set selector_safe [string map [list {$} "" "\x1b\[" "\x1b\]" {[} {]} :: {;} " " \t \n \r ] $selector] + + set cmdname ::punk::pipecmds::destructure_$selector_safe if {$cmdname in [info commands $cmdname]} { tailcall $cmdname $data } - set script "proc $cmdname {leveldata} {" - append script \n [string map [list $selector] {set selector ""}] ;# script should only need for error msgs + set body [destructure_func_build_procbody $cmdname $selector $data] + + puts stdout ---- + puts stderr "proc $cmdname {leveldata} {" + puts stderr $body + puts stderr "}" + puts stdout --- + proc $cmdname {leveldata} $body + #eval $script ;#create the proc + debug.punk.pipe.compile {proc $cmdname} 4 + #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + tailcall $cmdname $data + } + + #Builds a *basic* function to do the destructuring. + #This is simply a set of steps to destructure each level of the data based on the hierarchical selector. + #It just uses intermediate variables and adds some comments to the code to show the indices used at each point. + #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. + proc destructure_func_build_procbody {cmdname selector data} { + set script "" + #place selector in comment in script only - if there is an error in selector we pick it up when building the script. + #The script itself should only be returning errors in its action key of the result dictionary + append script \n [string map [list $selector] {# set selector {}}] set subindices [split $selector /] - append script \n [string map [list [list $subindices]] {set subindices }] + append script \n [string map [list [list $subindices]] {# set subindices }] set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break append script \n {set action ?match} #append script \n {set assigned ""} ;#review set active_key_type "" - append script \n {# set activey_key_type ""} - set lhs $selector - append script \n [string map [list $selector] {set lhs ""}] + append script \n {# set active_key_type ""} + set lhs "" + #append script \n [tstr {set lhs ${{$lhs}}}] + append script \n {set lhs ""} set rhs "" append script \n {set rhs ""} + set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope + + #maintain key order - caller unpacks using lassign + set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict - -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #dict 'index' when using stateful @@ etc to iterate over dict instead of by key + set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + - set selector_script_complete 0 if {![string length $selector]} { - append script \n { - set assigned $leveldata - set rhs $leveldata - set leveldata $assigned + #just return $leveldata + set script { + dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata } - set selector_script_complete 1 - } elseif {[string is digit -strict [join $subindices ""]]} { + return $script + } + + if {[string is digit -strict [join $subindices ""]]} { #review tip 551 (tcl9+?) #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" #pure numeric keylist - put straight to lindex @@ -1187,199 +1253,200 @@ namespace eval punk { #TODO - review and/or document # #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. + #(or more generally - loop until we hit another type of subindex) #set assigned [lindex $leveldata {*}$subindices] + if {[llength $subindices] == 1} { + append script \n "# index_operation listindex" \n + lappend INDEX_OPERATIONS listindex + } else { + append script \n "# index_operation listindex-nested" \n + lappend INDEX_OPERATIONS listindex-nested + } append script \n [string map [list $subindices] { - set assigned [lindex $leveldata ] - set rhs $leveldata - set leveldata $assigned - }] - set selector_script_complete 1 - } elseif {([scan $selector %d-%d a b] == 2) && $selector eq "${a}-${b}"} { - #single-level pure digit range a-b - no bounds checking - append script \n [string map [list $a $b] { - set assigned [lrange $leveldata ] - set rhs $leveldata - set leveldata $assigned + set leveldata [lindex $leveldata ] }] - #lset var_actions $i 1 ?set - #lset var_actions $i 2 $assigned - set selector_script_complete 1 - } elseif {$selector eq "0"} { - #review - can we get here? - append script \n { - if {[catch {lindex $leveldata 0} hd]} { - set action ?mismatch-not-a-list - } else { - set assigned $hd - set rhs $leveldata - set leveldata $assigned - } - } - set selector_script_complete 1 - } elseif {$selector eq "head"} { - #head is never allowed to match empty list - (vs anyhead to allow) - append script \n { - if {[catch {lindex $leveldata 0} hd]} { - set action ?mismatch-not-a-list - } else { - if {[llength $leveldata] == 0} { - set action ?mismatch-list-index-out-of-range-empty - } else { - set assigned $hd - set rhs $leveldata - set leveldata $assigned - } - } - } - set selector_script_complete 1 - } elseif {$selector eq "#"} { - # always present as /# - / required to separate from @@# maining dict key "#" - also leading # would be a comment. - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } else { - set assigned $len - set rhs $leveldata - set leveldata $assigned - } - } - set selector_script_complete 1 - } elseif {$selector eq "##"} { - # /## - append script \n { - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict - } else { - set assigned $dsize - set rhs $leveldata - set leveldata $assigned - } - } - set selector_script_complete 1 - } elseif {$selector eq "#?"} { - append script \n { - set assigned [string length $leveldata] - set rhs $leveldata - set leveldata $assigned - } - set selector_script_complete 1 - } elseif {[string match "@@*" $selector]} { + # -- --- --- + #append script \n $returnline \n + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + if {[string match @@* $selector]} { #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' set keypath [string range $selector 2 end] set keylist [split $keypath /] + lappend INDEX_OPERATIONS dict_path if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1)} { #pure keylist for dict - process in one go #dict exists will return 0 if not a valid dict. # is equivalent to {*}keylist when substituted - append script \n [string map [list $keylist] { - if {[dict exists $leveldata ]} { - set assigned [dict get $leveldata ] - set rhs $leveldata - set leveldata $assigned + append script \n [tstr -return string -allowcommands { + if {[dict exists $leveldata ${$keylist}]} { + set leveldata [dict get $leveldata ${$keylist}] } else { - set action ?mismatch-dict-key-not-found + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} } }] - set selector_script_complete 1 - } else { - #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) - #process level by level - set selector_script_complete 0 + append script [tstr -return string $return_template] + return $script + # -- --- --- } - } else { - set selector_script_complete 0 + #else + #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) + #process level by level } - if {!$selector_script_complete} { - - set i_keyindex 0 append script \n {set i_keyindex 0} #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? foreach index $subindices { + #set index_operation "unspecified" set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script - set subpath [join [lrange $subindices 0 $i_keyindex] /] - append script \n "# ------- START index $index ------" - append script \n "set subpath $subpath" - set lhs $subpath - append script \n "set lhs $subpath" + set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] + append script \n "# ------- START index:$index subpath:$SUBPATH ------" + set lhs $index + append script \n "set lhs $index" set assigned "" append script \n {set assigned ""} #got_not shouldn't need to be in script set get_not 0 + if {[tcl::string::index $index 0] eq "!"} { + append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} + set index [tcl::string::range $index 1 end] + set get_not 1 + } # do_bounds_check shouldn't need to be in script set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. #append script \n {set do_boundscheck 0} - - if {$index eq "#"} { - set active_key_type "list" - append script \n {# set active_key_type "list"} - append script \n { - if {[catch {llength $leveldata} assigned]} { - set action ?mismatch-not-a-list + switch -exact -- $index { + # { + #list length + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS not-list + append script \n {# set active_key_type "list" index_operation: not-list} + append script \n { + if {[catch {llength $leveldata}]} { + #not a list - not-length is true + set assigned 1 + } else { + #is a list - not-length is false + set assigned 0 + } + } + } else { + lappend INDEX_OPERATIONS list-length + append script \n {# set active_key_type "list" index_operation: list-length} + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} assigned]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] } + set level_script_complete 1 } - set level_script_complete 1 - } elseif {$index eq "##"} { - set active_key_type "dict" - append script \n {# set active_key_type "dict"} - append script \n { - if {[catch {dict size $leveldata} assigned]} { - set action ?mismatch-not-a-dict + ## { + #dict size + set active_key_type "dict" + if {$get_not} { + lappend INDEX_OPERATIONS not-dict + append script \n {# set active_key_type "dict" index_operation: not-dict} + append script \n { + if {[catch {dict size $leveldata}]} { + set assigned 1 ;#not a dict - not-size is true + } else { + set assigned 0 ;#is a dict - not-size is false + } + } + } else { + lappend INDEX_OPERATIONS dict-size + append script \n {# set active_key_type "dict" index_operation: dict-size} + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} assigned]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] } + set level_script_complete 1 } - set level_script_complete 1 - } elseif {$index eq "#?"} { - #set assigned [string length $leveldata] - append script \n {set assigned [string length $levedata]} - set level_script_complete 1 - } elseif {$index eq "@"} { - append script \n {upvar v_list_idx v_list_idx} - set active_key_type "list" - append script \n {# set active_key_type "list"} - #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey - #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 - #while x@,y@.= is reasonably handy - especially for args e.g $len} { - # set action ?mismatch-list-index-out-of-range - # break - #} - append script \n {set index [expr {[incr v_list_idx($subpath)]-1}]} - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } elseif {$index+1 > $len} { - set action ?mismatch-list-index-out-of-range + #? { + if $get_not { + error "!#? not string length is not supported" + } + #string length - REVIEW - + set index_operation string-length + append script \n {# set active_key_type "" index_operation: string-length} + append script \n {set assigned [string length $leveldata]} + set level_script_complete 1 + } + @ { + #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) + #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 + + + #append script \n {puts stderr [uplevel 1 [list info vars]]} + #v_list_idx in context of _multi_bind_result + append script \n {upvar v_list_idx v_list_idx} + set active_key_type "list" + append script \n {# set active_key_type "list" index_operation: get-next} + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set assigned 1 + } else { + set assigned 0 + } + }] + } else { - set assigned [lindex $leveldata $index] + lappend INDEX_OPERATIONS get-next + append script \n [tstr -return string -allowcommands { + set index [expr {[incr v_list_idx(@)]-1}] + + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$index+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + set assigned [lindex $leveldata $index] + } + }] } + set level_script_complete 1 } - #set assigned [lindex $leveldata $index] - set level_script_complete 1 - } else { - if {$index in [list "@@" "@?@" "@??@"]} { + @@ { + #stateful: tracking of index using v_dict_idx set active_key_type "dict" - append script \n {# set active_key_type "dict"} - append script \n {upvar v_dict_idx v_dict_idx} + lappend INDEX_OPERATIONS get-next-value + append script \n {# set active_key_type "dict" index_operation: get-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc #x@@ = a {x y} @@ -1387,166 +1454,525 @@ namespace eval punk { #x@@/@1 = x y #x@@/a = a {x y} # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. - # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) + # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) + #review - might be more useful if they shared an index ? # It is analogous to v1@,v2@ for lists. # @pairs is more useful for repeated operations - # - #if {[catch {dict size $leveldata} dsize]} { - # set action ?mismatch-not-a-dict - # break - #} else { - # set next_this_level [incr v_dict_idx($subpath)] - # set keyindex [expr {$next_this_level -1}] - # if {($keyindex + 1) <= $dsize} { - # set k [lindex [dict keys $leveldata] $keyindex] - # if {$index eq "@?@"} { - # set assigned [dict get $leveldata $k] - # } else { - # set assigned [list $k [dict get $leveldata $k]] - # } - # } else { - # if {$index eq "@@"} { - # set action ?mismatch-dict-index-out-of-range - # break - # } else { - # set assigned [list] - # } - # } - #} - - - set subscript { - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict - } else { - set next_this_level [incr v_dict_idx($subpath)] - set keyindex [expr {$next_this_level -1}] - - } - } set indent " " - if {$index eq "@?@"} { - set body [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - set assigned [dict get $leveldata $k] - } else { - set assigned [list] - } - }] - } elseif {$index eq "@@"} { - set body [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - set assigned [list $k [dict get $leveldata $k]] - } else { - set action ?mismatch-dict-index-out-of-range - } - }] - - } else { - set body [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - set assigned [list $k [dict get $leveldata $k]] - } else { - set assigned [list] - } - }] - } + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} + } + }] - append script \n [string map [list $body] $subscript] - set level_script_complete 1 + set assignment_script [tstr -ret string -allowcommands $assignment_script] - } elseif {[string match @@* $index]} { - set active_key_type "dict" - set key [string range $index 2 end] - #dict exists test is safe - no need for catch - append script \n [string map [list $key] { - # set active_key_type "dict" - if {[dict exists $leveldata ]} { - set assigned [dict get $leveldata ] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} } else { - set action ?mismatch-dict-key-not-found + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} } }] set level_script_complete 1 - } elseif {[string match {@\?@*} $index]} { + } + @?@ { + #stateful: tracking of index using v_dict_idx set active_key_type "dict" - set key [string range $index 3 end] - #dict exists test is safe - no need for catch - append script \n [string map [list $key] { - # set active_key_type "dict" - if {[dict exists $leveldata ]} { - set assigned [dict get $leveldata ] + lappend INDEX_OPERATIONS get?-next-value + append script \n {# set active_key_type "dict" index_operation: get?-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [dict get $leveldata $k] } else { set assigned [list] } }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] set level_script_complete 1 - } elseif {[string match {@\?\?@*} $index]} { + } + @??@ { set active_key_type "dict" - set key [string range $index 4 end] - #dict exists test is safe - no need for catch - append script \n [string map [list $key] { - # set active_key_type "dict" - if {[dict exists $leveldata ]} { - set assigned [list [dict get $leveldata ]] + lappend INDEX_OPERATIONS get?-next-pair + append script \n {# set active_key_type "dict" index_operation: get?-next-pair} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] } else { set assigned [list] } }] - set level_script_complete 1 - } elseif {[string match @* $index]} { - set active_key_type "list" - set do_bounds_check 1 - set index [string trimleft $index @] - append script \n [string map [list $index] { - # set active_key_type "list" - set index + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } }] - } else { - # + set level_script_complete 1 } + @vv@ - @VV@ - @kk@ - @KK@ { + error "unsupported index $index" + } + default { - - if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { - append script \n {#e.g not-0-end-1 not-end-4-end-2} - set get_not 1 - #cherry-pick some easy cases, and either assign, or re-map to corresponding index - switch -- $index { - not-tail { - append script \n {# set active_key_type "list"} - append script \n {set assigned [lindex $leveldata 0]} + #assert rules for values within @@ + #glob search is done only if there is at least one * within @@ + #if there is at least one ? within @@ - then a non match will not raise an error (quiet) + + #single or no char between @@: + #lookup/search is based on key - return is values + + #double char within @@: + #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ + #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ + #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value + #e.g @k*@ returns keys - search on values + #e.g @*k@ returns keys - search on keys + #e.g @v*@ returns values - search on values + #e.g @*v@ returns values - search on keys + + switch -glob -- $index { + @@* { + #exact key match - return value + #noisy get value - complain if key non-existent + #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped + set active_key_type "dict" + set key [string range $index 2 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-value-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-value-not + if {[dict exists $leveldata ${$key}]} { + set assigned [dict values [dict remove $leveldata ${$key}]] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-value + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-value" + if {[dict exists $leveldata ${$key}]} { + set assigned [dict get $leveldata ${$key}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } set level_script_complete 1 } - not-head - not-0 { - append script \n {# set active_key_type "list"} - append script \n {set assigned [lrange $leveldata 1 end]} + {@\?@*} { + #exact key match - quiet get value + #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict + #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not + set active_key_type "dict" + set key [string range $index 3 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-value-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-value-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict values [dict remove $leveldata ${$key}]] + }] + + } else { + lappend INDEX_OPERATIONS exactkey?-get-value + #dict exists test is safe - no need for catch + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-value + if {[dict exists $leveldata ]} { + set assigned [dict get $leveldata ] + } else { + set assigned [dict create] + } + }] + } set level_script_complete 1 } - not-end { - append script \n {# set active_key_type "list"} - append script \n {set assigned [lrange $leveldata 0 end-1]} + {@\?\?@*} { + #quiet get pairs + #this is silent too.. so how do we do a checked return of dict key+val? + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-pair-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-pair-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict remove $leveldata ${$key}] + }] + } else { + lappend INDEX_OPERATIONS exactkey?-get-pair + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-pair + if {[dict exists $leveldata ]} { + set assigned [dict create [dict get $leveldata ]] + } else { + set assigned [dict create] + } + }] + } set level_script_complete 1 } - default { - #trim off the not- and let the remaining index handle based on get_not being 1 - set index [string range $index 4 end] - append script \n "set index $index" - } - } - } - + @..@* - @kk@* - @KK@* { + #noisy get pairs by key + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-pairs-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-pairs-not + if {[dict exists $leveldata ${$key}]} { + set assigned [tcl::dict::remove $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] - } + } else { + lappend INDEX_OPERATIONS exactkey-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-pairs" + if {[dict exists $leveldata ${$key}]} { + tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + @vv@* - @VV@* { + #noisy(?) get pairs by exact value + #return mismatch on non-match even when not- specified + set active_key_type "dict" + set keyglob [string range $index 4 end] + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist + #The utility of this is debatable + lappend INDEX_OPERATIONS exactvalue-get-pairs-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactvalue-get-pairs-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set nonmatches [dict create] + tcl::dict::for {k v} $leveldata { + if {![string equal ${$key} $v]} { + dict set nonmatches $k $v + } + } + + if {[dict size $nonmatches] < [dict size $leveldata]} { + #our key matched something + set assigned $nonmatches + } else { + #our key didn't match anything - don't return the nonmatches + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactvalue-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactvalue-get-pairs-not" + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matches [list] + tcl::dict::for {k v} $leveldata { + if {[string equal ${$key} $v]} { + lappend matches $k $v + } + } + if {[llength $matches]} { + set assigned $matches + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + {@\*@*} - {@\*v@*} - {@\*V@*} { + #dict key glob - return values only + set active_key_type "dict" + if {[string match {@\*@*} $index]} { + set keyglob [string range $index 3 end] + } else { + #vV + set keyglob [string range $index 4 end] + } + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-values-not + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + # set active_key_type "dict" index_operation: globkey-get-values-not + set matched [dict keys $leveldata ${$keyglob}] + set assigned [dict values [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-values + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: globkey-get-values + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matched [dict keys $leveldata ${$keyglob}] + set assigned [list] + foreach m $matched { + lappend assigned [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + + } + {@\*.@*} { + #dict key glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-pairs-not + set matched [dict keys $leveldata ] + set assigned [dict remove $leveldata {*}$matched] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operations: globkey-get-pairs + set matched [dict keys $leveldata ] + set assigned [dict create] + foreach m $matched { + dict set assigned $m [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + } + {@\*k@*} - {@\*K@*} { + #dict key glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys-not + set matched [dict keys $leveldata ] + set assigned [dict keys [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys + set assigned [dict keys $leveldata ] + }] + } + set level_script_complete 1 + } + {@k\*@*} - {@K\*@*} { + #dict value glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match $v]} { + lappend assigned $k + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {[string match $v]} { + lappend assigned $k + } + } + }] + } + set level_script_complete 1 + } + {@.\*@*} { + #dict value glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {![string match $v]} { + dict set assigned $k $v + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + } + {@V\*@*} - {@v\*@*} { + #dict value glob - return values + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-values-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-values-not" + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match $v]} { + lappend assigned $v + } + } + }] + + } else { + lappend INDEX_OPERATIONS globvalue-get-values + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-value + set assigned [dict values $leveldata ] + }] + } + set level_script_complete 1 + + } + {@\*\*@} { + #dict val/key glob return pairs) + set active_key_type "dict" + set keyvalglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not + error "globkeyvalue-get-pairs-not todo" + } else { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs + append script \n [string map [list $keyvalglob] { + # set active_key_type "dict" index_operation: globkeyvalue-get-pairs-not" + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match $k] || [string match $v]} { + dict set assigned $k $v + } + } + }] + } + + error "globkeyvalue-get-pairs todo" + } + @* { + set active_key_type "list" + set do_bounds_check 1 + + set index [string trimleft $index @] + append script \n [string map [list $index] { + # set active_key_type "list" index_operation: ? + set index + }] + } + default { + puts "destructure_func_build_body unmatched index $index" + } + } + } + } if {!$level_script_complete} { - append script \n {if {$action eq "?match"}} " {" #keyword 'pipesyntax' at beginning of error message set listmsg "pipesyntax Unable to interpret subindex $index\n" @@ -1565,384 +1991,552 @@ namespace eval punk { set active_key_type "list" append script \n {# set active_key_type "list"} #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) - if {$index eq "0"} { - #if {[catch {llength $leveldata} len]} { - # set action ?mismatch-not-a-list - # break - #} - #set assigned [lindex $leveldata 0] - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } else { - set assigned [lindex $leveldata 0] - } - } - } elseif {$index eq "head"} { - #NOTE: /@head and /head both do bounds check. This is intentional - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } elseif {$len == 0} { - set action ?mismatch-list-index-out-of-range-empty + switch -exact -- $index { + 0 { + if {$get_not} { + append script \n "# index_operation listindex-int-not" \n + lappend INDEX_OPERATIONS listindex-zero-not + set assignment_script {set assigned [lrange $leveldata 1 end]} } else { - #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax - set assigned [lindex $leveldata 0] + append script \n "# index_operation listindex-int" \n + lappend INDEX_OPERATIONS listindex-zero + set assignment_script {set assigned [lindex $leveldata 0]} } - } - } elseif {$index eq "end"} { - if {$do_bounds_check} { - append script \n { + append script \n [tstr -return string -allowcommands { if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } elseif {$len < 1} { - set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - set assigned [lindex $leveldata end] + ${$assignment_script} } + }] + } + head { + #NOTE: /@head and /head both do bounds check. This is intentional + if {$get_not} { + append script \n "# index_operation listindex-head-not" \n + lappend INDEX_OPERATIONS listindex-head-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-head" \n + lappend INDEX_OPERATIONS listindex-head + set assignment_script {set assigned [lindex $leveldata 0]} } - } else { - append script \n { + append script \n [tstr -return string -allowcommands { if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range-empty + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} } else { - set assigned [lindex $leveldata end] + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + ${$assignment_script} } - } + }] } - - } elseif {$index eq "tail"} { - #NOTE: /@tail and /tail both do bounds check. This is intentional. - # - #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list - #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. - #In this way tail is different to @1-end - - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } elseif {$len == 0} { - set action ?mismatch-list-index-out-of-range + end { + if {$get_not} { + append script \n "# index_operation listindex-end-not" \n + lappend INDEX_OPERATIONS listindex-end-not + #on single element list Tcl's lrange will do what we want here and return nothing + set assignment_script {set assigned [lrange $leveldata 0 end-1]} } else { - set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. + append script \n "# index_operation listindex-end" \n + lappend INDEX_OPERATIONS listindex-end + set assignment_script {set assigned [lindex $leveldata end]} } - } - } elseif {$index eq "anyhead"} { - #allow returning of head or nothing if empty list - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list + if {$do_bounds_check} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] } else { - set assigned [lindex $leveldata 0] + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] } } - } elseif {$index eq "anytail"} { - #allow returning of tail or nothing if empty list - #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list + tail { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + # + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$get_not} { + append script \n "# index_operation listindex-tail-not" \n + lappend INDEX_OPERATIONS listindex-tail-not + set assignment_script {set assigned [lindex $leveldata 0]} } else { - set assigned [lrange $leveldata 1 end] - } + append script \n "# index_operation listindex-tail" \n + lappend INDEX_OPERATIONS listindex-tail + set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] } - } elseif {$index eq "init"} { - #all but last element - same as haskell 'init' - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list + anyhead { + #allow returning of head or nothing if empty list + if {$get_not} { + append script \n "# index_operation listindex-anyhead-not" \n + lappend INDEX_OPERATIONS listindex-anyhead-not + set assignment_script {set assigned [lrange $leveldata 1 end]} } else { - set assigned [lrange $leveldata 0 end-1] + append script \n "# index_operation listindex-anyhead" \n + lappend INDEX_OPERATIONS listindex-anyhead + set assignment_script {set assigned [lindex $leveldata 0]} } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] } - } elseif {$index eq "list"} { - #allow returning of entire list even if empty - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list + anytail { + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {$get_not} { + append script \n "# index_operation listindex-anytail-not" \n + lappend INDEX_OPERATIONS listindex-anytail-not + set assignment_script {set assigned [lindex $leveldata 0]} } else { - set assigned $leveldata + append script \n "# index_operation listindex-anytail" \n + lappend INDEX_OPERATIONS listindex-anytail + set assignment_script {set assigned [lrange $leveldata 1 end]} } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] } - } elseif {$index eq "raw"} { - #no list checking.. - append script \n {set assigned $leveldata} - } elseif {$index eq "keys"} { - #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements - append script \n { - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict + init { + #all but last element - same as haskell 'init' + #counterintuitively, get-notinit can therefore return first element if it is a single element list + #does bounds_check for get-not@init make sense here? maybe - review + if {$get_not} { + append script \n "# index_operation listindex-init-not" \n + lappend INDEX_OPERATIONS listindex-init-not + set assignment_script {set assigned [lindex $leveldata end]} } else { - set assigned [dict keys $leveldata] + append script \n "# index_operation listindex-init" \n + lappend INDEX_OPERATIONS listindex-init + set assignment_script {set assigned [lrange $leveldata 0 end-1]} } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] } - } elseif {$index eq "values"} { - #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements - append script \n { - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict + list { + #get_not? + #allow returning of entire list even if empty + if {$get_not} { + lappend INDEX_OPERATIONS list-getall-not + set assignment_script {set assigned {}} } else { - set assigned [dict values $leveldata] + lappend INDEX_OPERATIONS list-getall + set assignment_script {set assigned $leveldata} } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] } - } elseif {$index eq "pairs"} { - append script \n { - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict + raw { + #get_not - return nothing?? + #no list checking.. + if {$get_not} { + lappend INDEX_OPERATIONS getraw-not + append script \n {set assigned {}} } else { - set pairs [list] - tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} - set assigned [lindex [list $pairs [unset pairs]] 0] + lappend INDEX_OPERATIONS getraw + append script \n {set assigned $leveldata} } } - } elseif {[string is integer -strict $index]} { - - if {$get_not} { - set assign_script [string map [list $index] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] - } else { - set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] - } - - if {$do_bounds_check} { - if {$index < 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + keys { + #@get_not?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getkeys-not + set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values + } else { + lappend INDEX_OPERATIONS list-getkeys + set assignment_script {set assigned [dict keys $leveldata]} } - set max [expr {$index + 1}] - append script \n [string map [list $max $assign_script] { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} } else { - set max - # bounds_check due to @ directly specified in original index section - if {$max > $len} { - set action ?mismatch-list-index-out-of-range - } else { - - } - } - }] - } else { - append script \n [string map [list $assign_script] { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } else { - + ${$assignment_script} } }] } - } elseif {[string first "end" $index] >=0} { - if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { - + values { + #get_not ?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements if {$get_not} { - set assign_script [string map [list $index] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] + lappend INDEX_OPERATIONS list-getvalues-not + set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys } else { - set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}] - } - - if {$do_bounds_check} { - append script \n [string map [list $assign_script $endspec] { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } else { - #bounds-check is true - #leave the - from the end- as part of the offset - set offset [expr ] ;#don't brace! - if {($offset > 0 || abs($offset) >= $len)} { - set action ?mismatch-list-index-out-of-range - } else { - - } - } - }] - } else { - append script \n [string map [list $assign_script] { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } else { - - } - }] + lappend INDEX_OPERATIONS list-getvalues + set assignment_script {set assigned [dict values $leveldata]} } - - } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + pairs { + #get_not ?? if {$get_not} { - set assign_script [string map [list $start $end ] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] + #review - return empty list instead like not-list and not-raw? + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] } else { - set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + lappend INDEX_OPERATIONS list-getpairs } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } + }] + } + default { - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list + if {[string is integer -strict $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listindex-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex + set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] } - } - if {$do_bounds_check} { - if {[string is integer -strict $start]} { - if {$start < 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + if {$do_bounds_check} { + if {$index < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] } - append script \n [string map [list $start] { - set start - if {$start+1 > $len} { - set action ?mismatch-list-index-out-of-range + set max [expr {$index + 1}] + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + # bounds_check due to @ directly specified in original index section + if {${$max} > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } } }] - } elseif {$start eq "end"} { - #noop } else { - set startoffset [string range $start 3 end] ;#include the - from end- - set startoffset [expr $startoffset] ;#don't brace! - if {$startoffset > 0} { - #e.g end+1 - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] - - } - append script \n [string map [list $startoffset] { - set startoffset - if {abs($startoffset) >= $len} { - set action ?mismatch-list-index-out-of-range + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} } }] } - if {[string is integer -strict $end]} { - if {$end < 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + + if {$get_not} { + lappend INDEX_OPERATIONS listindex-endoffset-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex-endoffset + set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + #bounds-check is true + #leave the - from the end- as part of the offset + set offset [expr ${$endspec}] ;#don't brace! + if {($offset > 0 || abs($offset) >= $len)} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] } - append script \n [string map " $end" { - set end - if {$end+1 > $len} { - set action ?mismatch-list-index-out-of-range + + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + set assign_script [string map [list $start $end ] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS list-range + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } }] - } elseif {$end eq "end"} { - #noop - } else { - set endoffset [string range $end 3 end] ;#include the - from end- - set endoffset [expr $endoffset] ;#don't brace! - if {$endoffset > 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + if {$do_bounds_check} { + if {[string is integer -strict $start]} { + if {$start < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set start ${$start} + if {$start+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$start eq "end"} { + #noop + } else { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0} { + #e.g end+1 + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + + } + append script \n [tstr -return string -allowcommands { + set startoffset ${$startoffset} + if {abs($startoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + if {[string is integer -strict $end]} { + if {$end < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set end ${$end} + if {$end+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$end eq "end"} { + #noop + } else { + set endoffset [string range $end 3 end] ;#include the - from end- + + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set endoffset ${$endoffset} + if {abs($endoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } } - append script \n [string map " $endoffset" { - set endoffset - if {abs($endoffset) >= $len} { - set action ?mismatch-list-index-out-of-range + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + } }] - } - } - append script \n [string map [list $assign_script] { - if {![string match ?mismatch-* $action]} { - + } else { + #fail now - no need for script + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + #e.g @1-3 gets here + #JMN + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS list-range } - }] - } else { - #fail now - no need for script - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - } elseif {[string first - $index] > 0} { - if {$get_not} { - set assign_script [string map [list $index] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] - } else { - set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] - } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + + #review - Tcl lrange just returns nothing silently. + #if we don't intend to implement reverse indexing - we should probably not emit an error + if {$start > $end} { + puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + if {$do_bounds_check} { + #append script [string map [list $start $end] { + # set start + # set end + # if {$start+1 > $len || $end+1 > $len} { + # set action ?mismatch-list-index-out-of-range + # } + #}] + #set eplusone [expr {$end+1}] + append script [tstr -return string -allowcommands { + if {$len < ${[expr {$end+1}]}} { + set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + + + if {$get_not} { + set assign_script [string map [list $start $end] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } - append script \n { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } - } - #handle pure int-int ranges separately - set testindex [string map [list - "" + ""] $index] - if {[string is digit -strict $testindex]} { - #don't worry about leading - negative value for indices not valid anyway - set parts [split $index -] - if {[llength $parts] != 2} { + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #keyword 'pipesyntax' at beginning of error message + #pipesyntax error - no need to even build script - can fail now error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } - lassign $parts start end - append script [string map [list $start $end] { - set start - set end - if {$start+1 > $len || $end+1 > $len} { - set action ?mismatch-not-a-list - } - }] - } else { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } - - append script \n [string map [list $assign_script] { - if {![string match ?mismatch-* $action]} { - - } - }] - - } else { - #keyword 'pipesyntax' at beginning of error message - #pipesyntax error - no need to even build script - can fail now - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } } else { #treat as dict key - append script \n [string map [list $index] { - # set active_key_type "dict" - if {[dict exists $leveldata ]} { - set assigned [dict get $leveldata ] - } else { - set action ?mismatch-dict-key-not-found - } - }] + if {$get_not} { + #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? + append script \n [tstr -return string { + set assigned [dict remove $leveldata ${$index}] + }] + } else { + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" + if {[dict exists $leveldata {${$index}}]} { + set assigned [dict get $leveldata {${$index}}] + } else { + set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } } - append script \n "}" ;# if $action eq ?match - } ;# end if $level_script_complete append script \n { - if {$action eq "?match"} { - set rhs $leveldata - set leveldata $assigned - } + set leveldata $assigned } incr i_keyindex append script \n "# ------- END index $index ------" } ;# end foreach - } ;# end if !$selector_script_complete #puts stdout "----> destructure rep leveldata: [rep $leveldata]" #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" #maintain key order - caller unpacks using lassign - # - # - append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} - append script \n "}" \n - eval $script - debug.punk.pipe.compile {proc $cmdname} 4 - #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] - tailcall $cmdname $data + #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + append script \n [tstr -return string $return_template] \n + return $script } @@ -2104,7 +2698,7 @@ namespace eval punk { #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline proc _multi_bind_result {multivar data args} { - #puts stdout "---- _multi_bind_result $multivar $data $args" + #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 if {![string length $multivar]} { #treat the absence of a pattern as a match to anything @@ -2254,6 +2848,7 @@ namespace eval punk { set i 0 #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) foreach va $var_actions { + #val comes from -assigned lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" set varname [lindex $var_names $i] @@ -2266,18 +2861,18 @@ namespace eval punk { - set class_key [lindex $var_class $i 1] - set isatom [expr {$class_key == 1}] - set ispin [expr {2 in $class_key}] - set isbool [expr {3 in $class_key}] - set isint [expr {4 in $class_key}] - set isdouble [expr {5 in $class_key}] - set isvar [expr {$class_key == 6}] - set isglob [expr {7 in $class_key}] - set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) + set class_key [lindex $var_class $i 1] + set isatom [expr {$class_key == 1}] + set ispin [expr {2 in $class_key}] + set isbool [expr {3 in $class_key}] + set isint [expr {4 in $class_key}] + set isdouble [expr {5 in $class_key}] + set isvar [expr {$class_key == 6}] + set isglob [expr {7 in $class_key}] + set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) #marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? - set isgreaterthan [expr {9 in $class_key}] - set islessthan [expr {10 in $class_key}] + set isgreaterthan [expr {9 in $class_key}] + set islessthan [expr {10 in $class_key}] @@ -2762,7 +3357,7 @@ namespace eval punk { set i 0 foreach va $var_actions { #set isvar [expr {[lindex $var_class $i 1] == 6}] - if {([lindex $var_class $i 1] in [list 6 3]) && ([string length [set varname [lindex $var_names $i]]])} { + if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { #isvar lassign $va lhsspec act val upvar $lvlup $varname the_var @@ -2979,9 +3574,14 @@ namespace eval punk { #same with lsearch with a string pattern - #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps set script [string map [list $scopepattern $equalsrhs] { + #script built by punk::match_assign if {[llength $args]} { #scan for existence of any pipe operator (|*> or <*|) only - we don't need position #all pipe operators must be a single element + #we don't first check llength args == 1 because for example: + # x= <| + # x= |> + #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) foreach a $args { if {![catch {llength $a} sublen]} { #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} @@ -3010,7 +3610,8 @@ namespace eval punk { # We are probably only here if testing in the repl - in which case the error messages are important. set var_index_position_list [_split_equalsrhs $equalsrhs] #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" - # x='ok'/0 data + # x='ok'>0/0 data + # => {ok data} # we won't examine for vars as there is no pipeline - ignore # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) # we will differentiate between / and @ in the same way that general pattern matching works. @@ -3327,6 +3928,7 @@ namespace eval punk { #NOTE: the whole idea of scanning for %x% is a lot of work(performance penalty) #consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements + #possibly also *_ for expanded _ ? #This would simplify code a lot - but also quite possible to collide with user data. #Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) @@ -4726,6 +5328,7 @@ namespace eval punk { proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { + #puts stderr ". unknown dispatch $partzerozero" set argstail [lassign $args hd] #this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. @@ -6339,7 +6942,6 @@ namespace eval punk { #While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues #if the repl is used to launch/run a number of things in the one process proc d/ {args} { - #JMN set is_win [expr {"windows" eq $::tcl_platform(platform)}] set repl_runid [get_repl_runid] @@ -7230,7 +7832,7 @@ namespace eval punk { append warningblock \n "WARNING: textblock package couldn't be loaded. Side-by-side display not available" } else { - set introblock [textblock::join " " \n$mascotblock " " $text] + set introblock [textblock::join -- " " \n$mascotblock " " $text] } @@ -7269,7 +7871,7 @@ namespace eval punk { $t add_row [list $v $c2] } $t configure_column 0 -headers [list "Punk environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {all} + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} set punktable [$t print] $t destroy @@ -7284,11 +7886,11 @@ namespace eval punk { $t add_row [list $v $c2] } $t configure_column 0 -headers [list "Other environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {all} + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} set othertable [$t print] $t destroy - append text [textblock::join $punktable " " $othertable]\n + append text [textblock::join -- $punktable " " $othertable]\n } else { append text $linesep\n diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index e51eb929..55926216 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -64,50 +64,55 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::aliascore::class { - #*** !doctools - #[subsection {Namespace punk::aliascore::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} +#tcl::namespace::eval punk::aliascore::class { +# #*** !doctools +# #[subsection {Namespace punk::aliascore::class}] +# #[para] class definitions +# if {[info commands [namespace current]::interface_sample1] eq ""} { +# #*** !doctools +# #[list_begin enumerated] +# +# # oo::class create interface_sample1 { +# # #*** !doctools +# # #[enum] CLASS [class interface_sample1] +# # #[list_begin definitions] +# +# # method test {arg1} { +# # #*** !doctools +# # #[call class::interface_sample1 [method test] [arg arg1]] +# # #[para] test method +# # puts "test: $arg1" +# # } +# +# # #*** !doctools +# # #[list_end] [comment {-- end definitions interface_sample1}] +# # } +# +# #*** !doctools +# #[list_end] [comment {--- end class enumeration ---}] +# } +#} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::aliascore { - namespace export {[a-z]*} ;# Convention: export all lowercase +tcl::namespace::eval punk::aliascore { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable aliases - set aliases [dict create\ - list_as_lines punk::lib::list_as_lines\ - lines_as_list punk::lib::lines_as_list\ - linelist punk::lib::linelist\ - linesort punk::lib::linesort\ - pdict punk::lib::pdict\ - showdict punk::lib::showdict\ - ansistrip punk::ansi::stripansi\ + #use absolute ns ie must be prefixed with :: + #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased + set aliases [tcl::dict::create\ + tstr ::punk::lib::tstr\ + list_as_lines ::punk::lib::list_as_lines\ + lines_as_list ::punk::lib::lines_as_list\ + linelist ::punk::lib::linelist\ + linesort ::punk::lib::linesort\ + pdict ::punk::lib::pdict\ + plist [list ::punk::lib::pdict -roottype list]\ + showlist [list ::punk::lib::showdict -roottype list]\ + showdict ::punk::lib::showdict\ + ansistrip ::punk::ansi::stripansi\ ] #*** !doctools @@ -140,21 +145,37 @@ namespace eval punk::aliascore { set existing [list] set conflicts [list] foreach {a cmd} $aliases { - if {[info commands ::$a] ne ""} { + if {[tcl::info::commands ::$a] ne ""} { lappend existing $a - set existing_target [interp alias "" $a] + if {[llength $cmd] > 1} { + #use alias mechanism + set existing_target [interp alias "" $a] + } else { + #using namespace import + #check origin + set existing_target [tcl::namespace::origin $cmd] + } if {$existing_target ne $cmd} { - #command exists in global ns but is either an alias to something else, or some other type of command + #command exists in global ns but doesn't match our defined aliases/imports lappend conflicts $a } } } if {[llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases because -force == 0 and conflicts found:$conflicts" + error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" } } dict for {a cmd} $aliases { - interp alias {} $a {} {*}$cmd + if {[llength $cmd] > 1} { + interp alias {} $a {} {*}$cmd + } else { + if {[tcl::info::commands $cmd] ne ""} { + #todo - ensure exported? noclobber? + tcl::namespace::eval :: [list namespace import $cmd] + } else { + interp alias {} $a {} {*}$cmd + } + } } return [dict keys $aliases] } diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 5dcb7851..5f8484b8 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -1872,7 +1872,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t configure -frametype {} $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] - $t configure_column 0 -header_colspans [list all] + $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend grouptables [$t print] $t destroy @@ -1919,7 +1919,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t configure -frametype block $t configure_column 0 -headers [list "X11"] - $t configure_column 0 -header_colspans [list all] + $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend comparetables [$t print] $t destroy @@ -1940,7 +1940,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t configure -frametype block $t configure_column 0 -headers [list "Web"] - $t configure_column 0 -header_colspans [list all] + $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend comparetables [$t print] $t destroy @@ -2013,39 +2013,39 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try package require textblock - append out [textblock::join $indent [tcl::string::map $strmap $settings_applied]] \n - append out [textblock::join $indent [tcl::string::trim $SGR_colour_map \n]] \n - append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n + append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n + append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n + append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n set bgname "Web-white" set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour] set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"] set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour] set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"] - append out [textblock::join $indent [textblock::join -- $map1 $map2]] \n + append out [textblock::join -- $indent [textblock::join -- $map1 $map2]] \n append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n - append out [textblock::join $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n + append out [textblock::join -- $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n - append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n + append out [textblock::join -- $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n append out \n - append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n append out \n append out "[a+ {*}$fc web-white]16 Million colours[a]" \n #tcl::dict::set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585 - append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n - append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n + append out [textblock::join -- $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n + append out [textblock::join -- $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n append out \n append out "[a+ {*}$fc web-white]Web colours[a]" \n - append out [textblock::join $indent "To see all names use: a? web"] \n - append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n - append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n + append out [textblock::join -- $indent "To see all names use: a? web"] \n + append out [textblock::join -- $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n + append out [textblock::join -- $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n append out \n - append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n append out \n append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n - append out [textblock::join $indent "To see differences: a? x11"] \n + append out [textblock::join -- $indent "To see differences: a? x11"] \n if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { append out \n @@ -4226,6 +4226,9 @@ tcl::namespace::eval punk::ansi::ta { #can be used on dicts - but will check keys too. keys could also contain ansi and have escapes proc detect_in_list {list} { + detect [join $list " "] + } + proc detect_in_list2 {list} { foreach item $list { if {[detect $item]} { return 1 diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index d5c06d72..1b85cfec 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -332,7 +332,8 @@ tcl::namespace::eval punk::args { set in_record 0 foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] - if {![tcl::info::complete $recordsofar]} { + #ansi colours can stop info complete from working (contain square brackets) + if {![tcl::info::complete [punk::ansi::stripansi $recordsofar]]} { #append linebuild [string trimleft $rawline] \n if {$in_record} { if {[tcl::string::length $lastindent]} { @@ -436,6 +437,9 @@ tcl::namespace::eval punk::args { } none - any - ansistring { + } + list { + } default { #todo - disallow unknown types unless prefixed with custom- @@ -494,6 +498,9 @@ tcl::namespace::eval punk::args { } dict - dictionary { set v dict + } + list { + } default { #todo - disallow unknown types unless prefixed with custom- @@ -568,7 +575,9 @@ tcl::namespace::eval punk::args { "" - none { if {$is_opt} { tcl::dict::set spec_merged -type none - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } lappend opt_solos $argname } else { #-solo only valid for flags @@ -687,6 +696,7 @@ tcl::namespace::eval punk::args { } proc arg_error {msg spec_dict {badarg ""}} { + #todo - add checks column (e.g -minlen -maxlen) set errmsg $msg if {![catch {package require textblock}]} { if {[catch { @@ -798,7 +808,12 @@ tcl::namespace::eval punk::args { #Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg } - + + #todo - a version of get_dict that supports punk::lib::tstr templating + #rename get_dict + #provide ability to look up and reuse definitions from ids etc + # + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. #only supports -flag val pairs, not solo options @@ -849,7 +864,7 @@ tcl::namespace::eval punk::args { #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - error "unsupported" + error "unsupported number of arguments for punk::args::get_dict" set inopt 0 set k "" set i 0 @@ -887,8 +902,12 @@ tcl::namespace::eval punk::args { #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. #-default value must not be appended to if argname not yet in flagsreceived + + #todo: -minmultiple -maxmultiple ? + set opts $opt_defaults if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { + lappend flagsreceived -- set values [lrange $rawargs $eopts+1 end] set arglist [lrange $rawargs 0 $eopts-1] set maxidx [expr {[llength $arglist]-1}] @@ -908,7 +927,7 @@ tcl::namespace::eval punk::args { #review - what if user sets first value that happens to match a default? if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt [list $flagval] } else { tcl::dict::lappend opts $fullopt $flagval } @@ -997,7 +1016,7 @@ tcl::namespace::eval punk::args { #review - what if user sets first value that happens to match a default? if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt [list $flagval] } else { tcl::dict::lappend opts $fullopt $flagval } @@ -1079,7 +1098,7 @@ tcl::namespace::eval punk::args { if {[tcl::dict::get $arg_info $valname -multiple]} { if {[tcl::dict::exists $val_defaults $valname] && ([tcl::dict::get $val_defaults $valname] eq [tcl::dict::get $values_dict $valname])} { #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname $val + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list } else { tcl::dict::lappend values_dict $valname $val } @@ -1146,6 +1165,7 @@ tcl::namespace::eval punk::args { } + #todo - truncate/summarize values in error messages #todo - allow defaults outside of choices/ranges @@ -1205,6 +1225,9 @@ tcl::namespace::eval punk::args { } if {$is_default eq [llength $vlist]} { set is_default 1 + } else { + #important to set 0 here too e.g if only one element of many matches default + set is_default 0 } } #puts "argname:$argname v:$v is_default:$is_default" @@ -1214,6 +1237,32 @@ tcl::namespace::eval punk::args { if {$is_default == 0} { switch -- $type { any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minlen { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -minlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname + } + } + -maxlen { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -maxlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname + } + } + } + } + } + } + } + } string { if {[tcl::dict::size $thisarg_checks]} { foreach e_check $vlist_check { @@ -1295,6 +1344,25 @@ tcl::namespace::eval punk::args { if {[llength $e_check] %2 != 0} { arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs $argname } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minlen { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -minlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname + } + } + -maxlen { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -maxlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname + } + } + } + } + } + } } } alnum - diff --git a/src/modules/punk/basictelnet-999999.0a1.0.tm b/src/modules/punk/basictelnet-999999.0a1.0.tm index 329ad49f..36c1131b 100644 --- a/src/modules/punk/basictelnet-999999.0a1.0.tm +++ b/src/modules/punk/basictelnet-999999.0a1.0.tm @@ -475,7 +475,8 @@ namespace eval punk::basictelnet { reset_option_states set sock [socket $server $port] #fconfigure $sock -buffering none -blocking 0 -encoding binary -translation crlf -eofchar {} - fconfigure $sock -buffering none -blocking 0 -encoding binary -translation binary -eofchar {} + #fconfigure $sock -buffering none -blocking 0 -encoding binary -translation binary -eofchar {} + fconfigure $sock -buffering none -blocking 0 -encoding iso8859-1 -translation binary -eofchar {} fconfigure stdout -buffering none fileevent $sock readable [list [namespace current]::fromServer $sock] chan configure stdin -blocking 0 diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index c11d25df..d1a6d399 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -1811,7 +1811,6 @@ interp alias {} colour {} punk::console::colour interp alias {} ansi {} punk::console::ansi interp alias {} color {} punk::console::colour interp alias {} a+ {} punk::console::code_a+ -interp alias {} a= {} punk::console::code_a interp alias {} a {} punk::console::code_a interp alias {} a? {} punk::console::code_a? diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index 8691745f..90fb97b4 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -1259,18 +1259,17 @@ namespace eval punk::fileline { #[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data #[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used. #[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found - #[para]Specify -encoding binary to perform no encoding conversion #[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data #[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data #[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered. #[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7 - #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes (binary translation) + #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. - #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding binary if this isn't suitable and you need to do your own processing of the raw data. + #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. set argument_specification { -file -default {} -type existingfile - -translation -default binary + -translation -default iso8859-1 -encoding -default "\uFFFF" -includebom -default 0 *values -min 0 -max 1 diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index a0173c40..fb6d127a 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -395,26 +395,229 @@ namespace eval punk::lib { } } - proc pdict {args} { + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x 0] in calling scope ${[lindex [set x] 0]} !} + proc tstr {args} { + set argd [punk::args::get_dict { + *proc -name punk::lib::tstr -help "A rough equivalent of js template literals" + -allowcommands -default 0 -type none + -return -default list -choices {dict list string} + *values -min 1 -max 1 + templatestring -help "This argument should be a braced string containing placeholders such as ${$var} + where $var will be substituted from the calling context" + } $args] + set templatestring [dict get $argd values templatestring] + set opt_allowcommands [dict get $argd opts -allowcommands] + set opt_return [dict get $argd opts -return] + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + #set parts [_tstr_split $templatestring] + set parts [_parse_tstr_parts $templatestring] + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + #lappend expressions $expression + lappend params [uplevel 1 [list subst {*}$nocommands $expression]] + + incr idx ;#expression incr + } + switch -- $opt_return { + dict { + return [dict create template $textchunks params $params] + } + list { + return [list $textchunks {*}$params] + } + string { + set out "" + foreach pt $textchunks param $params { + append out $pt $param + } + return $out + } + default { + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + *proc -name tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[Tstr {Select * from table where id = ${$id} and etc... ;}] + } + + *values -min 2 -max 2 + template -type list -minlen 2 -maxlen 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the Tstr method above does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. Tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #get info about punk nestindex key ie type: list,dict,undetermined + proc nestindex_info {args} { set argd [punk::args::get_dict { + -parent -default "" + nestindex + } $args] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + + } + + + proc pdict {args} { + set sep " [a+ Web-seagreen]=[a] " + set argspec [string map [list %sep% $sep] { *proc -name pdict -help {Print dict keys,values to channel (see also showdict)} *opts -any 1 #default separator to provide similarity to tcl's parray function - -separator -default " = " + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" *values -min 1 -max -1 dictvar -type string -help "name of dict variable" - patterns -type string -default * -multiple 1 - } $args] + patterns -type string -default "*" -multiple 1 + }] + #puts stderr "$argspec" + set argd [punk::args::get_dict $argspec $args] + set opts [dict get $argd opts] set dvar [dict get $argd values dictvar] set patterns [dict get $argd values patterns] - set dvalue [uplevel 1 [list set $dvar]] + set isarray [uplevel 1 [list array exists $dvar]] + if {$isarray} { + set dvalue [uplevel 1 [list array get $dvar]] + dict set opts -keytemplates [list ${dvar}(%k%)] + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } showdict {*}$opts $dvalue {*}$patterns } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) - set argd [punk::args::get_dict { + set sep " [a+ Web-seagreen]=[a] " + set argd [punk::args::get_dict [string map [list %sep% $sep] { *id punk::lib::pdict *proc -name punk::lib::pdict -help "display dictionary keys and values" #todo - table tableobject @@ -423,77 +626,333 @@ namespace eval punk::lib { -trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line. This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding " - -separator -default " " -help "Separator column between keys and values" - -ansibase_keys -default "" - -ansibase_values -default "" + -separator -default "%sep%" -help "Separator column between keys and values" + -roottype -default "" -help "list,dict,string" + -substructure -default {} + -ansibase_keys -default "" -help "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -ansibase_values -default "" + -keytemplates -default {%k%} -type list -help "list of templates for keys at each level" -keysorttype -default "none" -choices {none dictionary ascii integer real} - -keysortdirection -default ascending -choices {ascending descending} + -keysortdirection -default increasing -choices {increasing decreasing} *values -min 1 -max -1 - dictvalue -type dict -help "dict value" - patterns -default * -type string -multiple 1 -help "key or key glob pattern" - } $args] + dictvalue -type list -help "dict or list value" + patterns -default "*" -type string -multiple 1 -help "key or key glob pattern" + }] $args] set opt_sep [dict get $argd opts -separator] set opt_keysorttype [dict get $argd opts -keysorttype] set opt_keysortdirection [dict get $argd opts -keysortdirection] set opt_trimright [dict get $argd opts -trimright] - set opt_ansibase_key [dict get $argd opts -ansibase_keys] - set opt_ansibase_value [dict get $argd opts -ansibase_values] + set opt_keytemplates [dict get $argd opts -keytemplates] + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] set dval [dict get $argd values dictvalue] set patterns [dict get $argd values patterns] set result "" + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set filtered_keys [list] - foreach p $patterns { - lappend filtered_keys {*}[dict keys $dval $p] - } - if {$opt_keysorttype eq "none"} { - #we can only get duplicate keys if there are multiple patterns supplied - #ignore keysortdirection - doesn't apply - if {[llength $patterns] > 1} { - #order-maintaining (order of keys as they appear in dict) - set filtered_keys [punk::lib::lunique $filtered_keys] + if {$opt_roottype eq "list"} { + #puts "getting keys for list" + if {[llength $dval]} { + set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} + set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + foreach pattern_nest $patterns { + set keyset [list] + set pattern_nest_list [split $patterns /] + set p [lindex $pattern_nest_list 0] + if {$p eq ""} { + continue + } + if {$p eq "*"} { + lappend keyset {*}[punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + } else { + if {[string match @* $p]} { + #already in list mode - trim optional list specifier @ + set p [string range $p 1 end] + } + + if {[string is integer -strict $p]} { + lappend keyset $p + } elseif {[string match "?*-?*" $p]} { + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high + #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds + if {${lower_resolve} == -1} { + #lower bound is above upper list range + #match with decreasing indices is still possible + set lower [expr {[llength $dval]-1}] ;#set to max + } elseif {$lower_resolve == -2} { + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve $dval $b] + if {$upper == -2} { + #upper bound is below list range - + if {$lower_resolve >=-1} { + set upper 0 + } else { + continue + } + } elseif {$upper == -1} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + lappend keyset {*}[punk::lib::range $lower $upper] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + + + # -- --- --- --- + #check next pattern for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $pattern_nest_list 1] + if {$pnext in [list "@*k@*" "@*K@*" "@*.@*" *]} { + set substructure dict + } elseif {[string match "@??@*" $pnext] || [string match "@?@*" $pnext]} { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } elseif {[string match @@* $pnext]} { + set substructure dict + } elseif {[string match @* $pnext]} { + #if we've ruled out all explicit dict patterns - @* is list + set substructure list + } elseif {$pnext eq ""} { + set substructure "string" + } else { + #plain keys are now dict because there was no list-type pattern to flip the structure type + set substructure dict + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + + + lappend filtered_keys {*}$keyset + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + } } + #puts stderr "list keys: $filtered_keys" + } elseif {$opt_roottype eq "dict"} { + foreach pattern_nest $patterns { + set keyset [list] + set pattern_nest_list [split $pattern_nest /] + set p [lindex $pattern_nest_list 0] + if {$p in [list "@*k@*" "@*K@*" "@*.@*" *]} { + #exact glob-for-all + lappend keyset {*}[dict keys $dval] + } elseif {[string match @@* $p]} { + set k [string range $p 2 end] + lappend keyset {*}[dict keys $dval $k] + } elseif {[string match -nocase {@k\*@*}]} { + set k [string range $p 4 end] + lappend keyset {*}[dict keys $dval $k] + } elseif {[string match {@\*@*} $p]} { + set k [string range $p 3 end] + lappend keyset {*}[dict keys $dval $k] + } elseif {[string match -nocase {@v\*@*} $p] || [string match -nocase {@\*v@*} $p]} { + #don't match @v.@ + error "dict value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + } else { + lappend keyset {*}[dict keys $dval $p] + } + # -- --- --- --- + #check next pattern for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $pattern_nest_list 1] + if {$pnext in [list "@*k@*" "@*K@*" "@*.@*" *]} { + set substructure dict + } elseif {[string match "@??@*" $pnext] || [string match "@?@*" $pnext]} { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } elseif {[string match @@* $pnext]} { + set substructure dict + } elseif {[string match @* $pnext]} { + #if we've ruled out all explicit dict patterns - @* is list + set substructure list + } elseif {$pnext eq ""} { + set substructure "string" + } else { + #plain keys are now dict because there was no list-type pattern to flip the structure type + set substructure dict + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + #puts stderr "adding [llength $keyset] keys for pattern_nest: $pattern_nest" + #sort only within each pattern for now + if {$opt_keysorttype ne "none"} { + set keyset [lsort -$opt_keysorttype -$opt_keysortdirection $keyset] + } + lappend filtered_keys {*}$keyset + + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + } + + #todo - fix. sorting keys wrecks pattern_key_index + #if {$opt_keysorttype eq "none"} { + # #we can only get duplicate keys if there are multiple patterns supplied + # #ignore keysortdirection - doesn't apply + # if {[llength $patterns] > 1} { + # #order-maintaining (order of keys as they appear in dict) + # set filtered_keys [punk::lib::lunique $filtered_keys] + # } + #} else { + # set filtered_keys [lsort -unique -$opt_keysorttype -$opt_keysortdirection $filtered_keys] + #} } else { - set filtered_keys [lsort -unique -$opt_keysorttype $opt_keysortdirection $filtered_keys] + #string + puts stdout "xxxx string" + return $dval } if {[llength $filtered_keys]} { #both keys and values could have newline characters. #simple use of 'format' won't cut it for more complex dict keys/values #use block::width or our columns won't align in some cases - set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] set RST [a] switch -- $opt_return { "tailtohead" { #last line of key is side by side (possibly with separator) with first line of value #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries - foreach key $filtered_keys { - lassign [textblock::size $key] _kw kwidth _kh kheight - lassign [textblock::size [dict get $dval $key]] _vw vwidth _vh vheight + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + foreach keydisplay $display_keys key $filtered_keys { + if {$opt_roottype eq "list"} { + set thisval [lindex $dval $key] + } else { + #todo - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + set thisval [tcl::dict::get $dval $key] + } + if {$opt_roottype eq "dict"} { + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + set pattern_nest [lindex $pattern_key_index $kidx] + set nextsub [dict get $pattern_next_substructure $pattern_nest] + #which pattern nest applies to this branch + set pattern_nest_list [split $pattern_nest /] + if {[llength $pattern_nest_list]} { + set tail [lassign $pattern_nest_list parent] + set nest $tail + #if {![llength $tail]} { + # set nest * + #} + lappend nextpatterns [join $nest /] + } + #puts "k:$key dict nextpatterns: $nextpatterns" + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + set nextopts [dict get $argd opts] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + + + if {[llength $nextpatterns] && $nextsub ne "string"} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } elseif {$opt_roottype eq "list"} { + + set nextpatterns [list] + set pattern_nest [lindex $pattern_key_index $kidx] + set nextsub [dict get $pattern_next_substructure $pattern_nest] + set pattern_nest_list [split $pattern_nest /] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + if {![llength $nest]} { + set nest * + } + lappend nextpatterns [join $nest /] + } + #puts "list nextpattern: $nextpatterns" + + set nextopts [dict get $argd opts] + #dict set nextopts -substructure $substructure + dict set nextopts -channel none + dict set nextopts -roottype $nextsub + + + if {![llength $nextpatterns]} { + set nextpatterns * + } + if {[llength $nextpatterns] && $nextsub ne "string"} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + } + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + set totalheight [expr {$kheight + $vheight -1}] set blanks_above [string repeat \n [expr {$kheight -1}]] set blanks_below [string repeat \n [expr {$vheight -1}]] set sepwidth [textblock::width $opt_sep] - #append result [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep $opt_ansibase_value[dict get $dval $key]$RST \n - set kblock [textblock::pad $opt_ansibase_key$key$RST$blanks_below -width $maxl] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] set sblock [textblock::pad $blanks_above$opt_sep$blanks_below -width $sepwidth] - set vblock $blanks_above$opt_ansibase_value[dict get $dval $key]$RST + set vblock $blanks_above$opt_ansibase_values$thisval$RST #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace - append result [textblock::join_basic $kblock $sblock $vblock] \n + append result [textblock::join_basic -- $kblock $sblock $vblock] \n + incr kidx } } "sidebyside" { #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. #use ansibase_key etc to make the output more comprehensible in that situation. #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic - append result [textblock::join -- [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep "$opt_ansibase_value[dict get $dval $key]$RST"] \n + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n } } } @@ -765,19 +1224,23 @@ namespace eval punk::lib { #[para]This means the proc may be called with something like $x+2 end-$y etc #[para]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. - #[para]lindex_resolve will parse the index expression and return -1 if the supplied index expression is out of bounds for the supplied list. + #[para]lindex_resolve will parse the index expression and return: + #[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) + #[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para]Otherwise it will return an integer corresponding to the position in the list. + #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr - if {![llength $list]} { - return -1 - } + #if {![llength $list]} { + # #review + # return ??? + #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { #can match +i -i if {$index < 0} { - return -1 + return -2 } elseif {$index >= [llength $list]} { return -1 } else { @@ -794,16 +1257,28 @@ namespace eval punk::lib { return -1 } } else { - set offset 0 + #end + set index [expr {[llength $list]-1}] + if {$index < 0} { + #special case - end with empty list - treat end like a positive number out of bounds + return -1 + } else { + return $index + } } - #by now, if op = + then offset = 0 so we only need to handle the minus case if {$offset == 0} { set index [expr {[llength $list]-1}] + if {$index < 0} { + return -1 ;#special case + } else { + return $index + } } else { + #by now, if op = + then offset = 0 so we only need to handle the minus case set index [expr {([llength $list]-1) - $offset}] } if {$index < 0} { - return -1 + return -2 } else { return $index } @@ -823,16 +1298,25 @@ namespace eval punk::lib { } else { error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" } - if {$index < 0 || $index >= [llength $list]} {return -1} + if {$index < 0} { + return -2 + } elseif {$index >= [llength $list]} { + return -1 + } return $index } } } proc lindex_resolve2 {list index} { - set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. - for {set i 0} {$i < [llength $list]} {incr i} { - lappend indices $i - } + #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. + #for {set i 0} {$i < [llength $list]} {incr i} { + # lappend indices $i + #} + if {[llength $list]} { + set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. + } else { + set indices [list] + } set idx [lindex $indices $index] if {$idx eq ""} { return -1 diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index ef4a0eb0..999ea8e6 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -1166,24 +1166,6 @@ tcl::namespace::eval punk::ns { lappend allooclasses $cmd } } - if {[catch { - if {$cmd eq ""} { - #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. - set nsorigin [namespace origin ${location}::] - } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] - } else { - set nsorigin [namespace origin [nsjoin $location $cmd]] - } - } errM]} { - puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" - puts stderr "error message: $errM" - lappend allundetermined $cmd - } else { - if {[nsprefix $nsorigin] ne $location} { - lappend allimported $cmd - } - } } default { if {$ctype eq "imported"} { @@ -1242,6 +1224,25 @@ tcl::namespace::eval punk::ns { } } + #JMN + if {[catch { + if {$cmd eq ""} { + #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. + set nsorigin [namespace origin ${location}::] + } elseif {[string match :* $cmd]} { + set nsorigin [nseval $location "::namespace origin $cmd"] + } else { + set nsorigin [namespace origin [nsjoin $location $cmd]] + } + } errM]} { + puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" + puts stderr "error message: $errM" + lappend allundetermined $cmd + } else { + if {[nsprefix $nsorigin] ne $location} { + lappend allimported $cmd + } + } } if {$glob ne "*"} { set childtailmatches [lsearch -all -inline $childtails $glob] diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 55055cf9..98d0058a 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -1876,8 +1876,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set stdinconf [fconfigure $inputchan] if {$::tcl_platform(platform) eq "windows" && [dict get $stdinconf -encoding] ni [list unicode utf-16 utf-8]} { #some long console inputs are split weirdly when -encoding and -translation are left at defaults - requiring extra enter-key to get repl to process. - #experiment to see if using binary and handling line endings manually gives insight. - # - do: chan conf stdin -encoding binary -translation lf + #experiment to see if using iso8859-1 (raw bytes) and handling line endings manually gives insight. + # - do: chan conf stdin -encoding iso859-1 -translation lf #first command after configuring stdin this way seems to be interpreted with wrong encoding - subsequent commands work - review @@ -2015,7 +2015,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set status [catch {uplevel #0 [list runraw $commandstr]} raw_result] } else { #puts stderr "repl uplevel 0 '$run_command_string'" - + #JMN + #puts stderr "sending to codethread::runscript $run_command_string" tsv::set codethread_$codethread status -1 thread::send -async $codethread [list punk::repl::codethread::runscript $run_command_string] thread::mutex lock $codethread_mutex @@ -2762,8 +2763,8 @@ namespace eval repl { code alias ::punk::set_repl_last_unknown ::repl::interphelpers::set_repl_last_unknown code alias ::punk::get_repl_runid ::repl::interphelpers::get_repl_runid - - code alias cmdtype ::repl::interphelpers::cmdtype + #JMN + #code alias cmdtype ::repl::interphelpers::cmdtype #temporary debug aliases - deliberate violation of safety provided by safe interp code alias escapeeval ::repl::interphelpers::escapeeval diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 99b54e3a..bf9f1160 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -836,7 +836,7 @@ tcl::namespace::eval textblock { set args_got_header_colspans 1 #check columns to left to make sure each new colspan for this column makes sense in the overall context #user may have to adjust colspans in order left to right to avoid these check errors - #note that 'all' represents span all up to the next non-zero defined colspan. + #note that 'any' represents span all up to the next non-zero defined colspan. set cspans [my header_colspans] set h 0 if {[llength $v] > [tcl::dict::size $cspans]} { @@ -846,34 +846,34 @@ tcl::namespace::eval textblock { if {$cidx == 0} { if {[tcl::string::is integer -strict $s]} { if {$s < 1} { - error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'all' or a positive integer" + error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" } } else { - if {$s ne "all" && $s ne ""} { - error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'" + if {$s ne "any" && $s ne ""} { + error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" } } } else { #if {![tcl::string::is integer -strict $s]} { - # if {$s ne "all" && $s ne ""} { - # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'" + # if {$s ne "any" && $s ne ""} { + # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" # } #} else { set header_spans [tcl::dict::get $cspans $h] set remaining [lindex $header_spans 0] - if {$remaining ne "all"} { + if {$remaining ne "any"} { incr remaining -1 } #look at spans defined for previous cols #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption for {set c 0} {$c < $cidx} {incr c} { set span [lindex $header_spans $c] - if {$span eq "all"} { - set remaining "all" + if {$span eq "any"} { + set remaining "any" } else { - if {$remaining eq "all"} { + if {$remaining eq "any"} { if {$span ne "0"} { - #a previous column has ended the 'all' span + #a previous column has ended the 'any' span set remaining [expr {$span -1}] } } else { @@ -886,8 +886,8 @@ tcl::namespace::eval textblock { } } } - if {$remaining eq "all"} { - #any int >0 ok - what about 'all' immediately following all? + if {$remaining eq "any"} { + #any int >0 ok - what about 'any' immediately following any? } else { if {$remaining > 0} { if {$s ne "0" && $s ne ""} { @@ -895,7 +895,7 @@ tcl::namespace::eval textblock { } } else { if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'all'" + error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" } } } @@ -1020,10 +1020,11 @@ tcl::namespace::eval textblock { #return a dict keyed on header index with values representing colspans #e.g - # 0 {all 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} # method header_colspans {} { - set num_headers [my header_count_calc] + #set num_headers [my header_count_calc] + set num_headers [my header_count] set colspans_by_header [tcl::dict::create] tcl::dict::for {cidx cdef} $o_columndefs { set headerlist [tcl::dict::get $cdef -headers] @@ -1033,17 +1034,17 @@ tcl::namespace::eval textblock { set defined_span [lindex $colspans_for_column $h] set i 0 set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "all"} { + if {$spanremaining ne "any"} { if {$spanremaining eq ""} { set spanremaining 1 } incr spanremaining -1 } foreach s $headerspans { - if {$s eq "all"} { - set spanremaining "all" + if {$s eq "any"} { + set spanremaining "any" } elseif {$s == 0} { - if {$spanremaining ne "all"} { + if {$spanremaining ne "any"} { incr spanremaining -1 } } else { @@ -1055,7 +1056,7 @@ tcl::namespace::eval textblock { if {$spanremaining eq "0"} { lappend headerspans 1 } else { - #"all" or an integer + #"any" or an integer lappend headerspans 0 } } else { @@ -1067,6 +1068,39 @@ tcl::namespace::eval textblock { return $colspans_by_header } + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} + #convert to + # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + method header_colspans_numeric {} { + set hcolspans [my header_colspans] + if {![tcl::dict::size $hcolspans]} { + return + } + set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same + tcl::dict::for {h spans} $hcolspans { + set c 0 ;#column index + foreach s $spans { + if {$s eq "any"} { + set spanlen 1 + for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { + #next 'any' or non-zero ends an 'any' span + if {[lindex $spans $i] ne "0"} { + break + } + incr spanlen + } + #overwrite the 'any' with it's actual span + set modified_spans [dict get $hcolspans $h] + lset modified_spans $c $spanlen + dict set hcolspans $h $modified_spans + } + incr c + } + } + return $hcolspans + } + #should be configure_headerrow ? method configure_header {index_expression args} { #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. @@ -1103,6 +1137,10 @@ tcl::namespace::eval textblock { #set val [tcl::dict::get $o_rowdefs $ridx $k] set infodict [tcl::dict::create] + #todo + # -blockalignments and -textalignments lists + # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} + #if there is a value it overrides alignments specified on the column switch -- $k { -values { set header_row_items [list] @@ -1190,54 +1228,54 @@ tcl::namespace::eval textblock { if {[llength $v]} { set firstspan [lindex $v 0] set first_is_ok 0 - if {$firstspan eq "all"} { + if {$firstspan eq "any"} { set first_is_ok 1 } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { set first_is_ok 1 } if {!$first_is_ok} { - error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"all\"" + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" } #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) set remaining $firstspan - if {$remaining ne "all"} { + if {$remaining ne "any"} { incr remaining -1 } set spanview $v set sidx 1 - #because we allow 'all' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'all' first + #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first foreach span [lrange $v 1 end] { - if {$remaining eq "all"} { - if {$span eq "all"} { - set remaining "all" + if {$remaining eq "any"} { + if {$span eq "any"} { + set remaining "any" } elseif {$span > 0} { - #ok to reset to higher val immediately or after an all and any number of following zeros + #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"all\".[a] $spanview" + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span incr remaining -1 } else { - #zero following an all - leave remaining as all + #zero following an any - leave remaining as any } } else { if {$span eq "0"} { if {$remaining eq "0"} { lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"all\" value.[a] $spanview" + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" } else { incr remaining -1 } } else { if {$remaining eq "0"} { - #ok for new span value of all or > 0 - if {$span ne "all" && $span > ($numcols - $sidx)} { + #ok for new span value of any or > 0 + if {$span ne "any" && $span > ($numcols - $sidx)} { lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"all\".[a] $spanview" + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span - if {$remaining ne "all"} { + if {$remaining ne "any"} { incr remaining -1 } } else { @@ -1760,8 +1798,8 @@ tcl::namespace::eval textblock { set hdrmap [tcl::dict::get $hmap only${opt_posn}] set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] - set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] + set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] @@ -1795,16 +1833,19 @@ tcl::namespace::eval textblock { #set hcolwidth [my column_width_configured $cidx] set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - set all_colspans [my header_colspans] + set all_colspans [my header_colspans_numeric] + #put our framedef calls together + set fdef_header [textblock::framedef $ftype_header] + set framedef_leftbox [textblock::framedef -joins left $ftype_header] + set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] + set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] #default span_extend_map - used as base to customise with specific joins - set fdef_header [textblock::framedef $ftype_header] set span_extend_map [tcl::dict::create \ vll " "\ tlc [tcl::dict::get $fdef_header hlt]\ blc [tcl::dict::get $fdef_header hlb]\ ] - set framedef_leftbox [textblock::framedef $ftype_header -joins left] #used for colspan-zero header frames @@ -1851,7 +1892,10 @@ tcl::namespace::eval textblock { } #puts ">>> headerspans: $headerspans cidx: $cidx" - if {$this_span eq "all" || $this_span > 0} { + #if {$this_span eq "any" || $this_span > 0} {} + #changed to processing only numeric colspans + + if {$this_span > 0} { set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] #look at spans in header below to determine joins required at blc if {$show_seps_v} { @@ -1882,7 +1926,7 @@ tcl::namespace::eval textblock { # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ # ] - if {$this_span eq "1"} { + if {$this_span == 1} { #write the actual value now set cellcontents $hval } else { @@ -1894,13 +1938,20 @@ tcl::namespace::eval textblock { -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ ] - if {$this_span ne "1"} { + if {$this_span != 1} { #puts "===>\n$header_cell_startspan\n<===" set spanned_parts [list $header_cell_startspan] - #assert this_span == "all" or >1 ie a header that spans other columns + #assert this_span == "any" or >1 ie a header that spans other columns #therefore more parts to append #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] set remaining_spans [lrange $headerspans $cidx+1 end] + set spanval [join $remaining_spans ""] ;#so we can test for all zeros + set spans_to_rhs 0 + if {[expr {$spanval}] == 0} { + #puts stderr "SPANS TO RHS" + set spans_to_rhs 1 + } + #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] @@ -1944,13 +1995,11 @@ tcl::namespace::eval textblock { if {[llength $next_spanlist]} { set spanbelow [lindex $next_spanlist $spancol] if {$spanbelow != 0} { - set downbox [textblock::framedef $ftype_header -joins {down}] - tcl::dict::set this_span_map blc [tcl::dict::get $downbox hlbj] ;#horizontal line bottom with down join - to same frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype } } else { #join to body - set downbox [textblock::framedef $ftype_header -joins [list down-$fname_body]] - tcl::dict::set this_span_map blc [tcl::dict::get $downbox hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } @@ -1980,17 +2029,38 @@ tcl::namespace::eval textblock { #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic set spanned_frame [textblock::join_basic -- {*}$spanned_parts] - if {$hrow == 0} { - set hlims $header_boxlimits_toprow + if {$spans_to_rhs} { + if {$cidx == 0} { + set fake_posn solo + } else { + set fake_posn right + } + set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] + if {$hrow == 0} { + set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] + } else { + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] + } } else { - set hlims $header_boxlimits + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + } else { + set hlims $header_boxlimits + } } if {!$show_seps_v} { set hlims [struct::set difference $hlims $headerseps_v] } if {![tcl::dict::get $o_opts_table -show_edge]} { - #use the edge_parts corresponding to the column being written to ie use opt_posn - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + if {$spans_to_rhs} { + #assert fake_posn has been set above based on cidx and spans_to_rhs + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] + } else { + #use the edge_parts corresponding to the column being written to ie use opt_posn + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } } set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements @@ -2005,7 +2075,21 @@ tcl::namespace::eval textblock { #set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock] #spanned values default left - todo make configurable + + #TODO + #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span + #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? + #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. + #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + #POTENTIAL BUG (fixed with spans_to_rhs above) + #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) + #we need to shift 1 to the left when doing our overtype with blockalign right + #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge + #(even though the column position may be left or inner) + + } else { #this_span == 1 @@ -2301,11 +2385,9 @@ tcl::namespace::eval textblock { error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } #assert cidx is integer >=0 + set num_header_rows [my header_count] set cdef [tcl::dict::get $o_columndefs $cidx] set headerlist [tcl::dict::get $cdef -headers] - set num_header_rows [my header_count] - - set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] set ansibase_col [tcl::dict::get $cdef -ansibase] set textalign [tcl::dict::get $cdef -textalign] switch -- $textalign { @@ -2316,20 +2398,23 @@ tcl::namespace::eval textblock { } } + set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] #set header_underlay $ansibase_header$cell_line_blank #set hdrwidth [my column_width_configured $cidx] - set all_colspans [my header_colspans] - + #set all_colspans [my header_colspans] + #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric + set all_colspans [my header_colspans_numeric] + #JMN #store configured widths so we don't look up for each header line - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - #lappend configured_widths [my column_width $c] - #we don't just want the width of the column in the body - or the headers will get truncated - lappend configured_widths [my column_width_configured $c] - } + #set configured_widths [list] + #foreach c [tcl::dict::keys $o_columndefs] { + # #lappend configured_widths [my column_width $c] + # #we don't just want the width of the column in the body - or the headers will get truncated + # lappend configured_widths [my column_width_configured $c] + #} set output [tcl::dict::create] tcl::dict::set output headers [list] @@ -2342,7 +2427,7 @@ tcl::namespace::eval textblock { set this_span [lindex $headerrow_colspans $cidx] #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span] ;#widest of headers in this col with same span - allows textalign to work with blockalign + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] @@ -2704,7 +2789,7 @@ tcl::namespace::eval textblock { set width_max [expr {max($test_width,$width_max)}] continue } - if {$spanc eq "all" || $spanc > 1} { + if {$spanc eq "any" || $spanc > 1} { set spanned [list] ;#spanned is other columns spanned - not including this one set cnext [expr {$cidx +1}] set spanlength [lindex $colspans $cnext] @@ -2773,10 +2858,12 @@ tcl::namespace::eval textblock { set opts [tcl::dict::create\ -headers 0\ -footers 0\ - -colspan *\ + -colspan unspecified\ -data 1\ -cached 1\ ] + #NOTE: -colspan any is not the same as * + # #-colspan is relevant to header/footer data only foreach {k v} $args { switch -- $k { @@ -2789,6 +2876,17 @@ tcl::namespace::eval textblock { } } set opt_colspan [tcl::dict::get $opts -colspan] + switch -- $opt_colspan { + * - unspecified {} + any { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" + } + default { + if {![string is integer -strict $opt_colspan]} { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" + } + } + } set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] @@ -2801,26 +2899,26 @@ tcl::namespace::eval textblock { set bwidest 0 set fwidest 0 if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan eq "*"} { + if {$opt_colspan in {* unspecified}} { set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] } else { + #this is not cached + # -- --- --- --- set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans] + set all_colspans_by_header [my header_colspans_numeric] set hlist [list] tcl::dict::for {hrow cspans} $all_colspans_by_header { set s [lindex $cspans $cidx] - #todo - map 'all' entries to a number? - #we should build a version of header_colspans that does this if {$s eq $opt_colspan} { lappend hlist [lindex $colheaders $hrow] } } - #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {tcl::string::length $v}]] if {[llength $hlist]} { set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] } else { set hwidest 0 } + # -- --- --- --- } } if {[tcl::dict::get $opts -data]} { @@ -2835,8 +2933,28 @@ tcl::namespace::eval textblock { #assert cidx is >=0 integer in valid range of keys for o_columndefs set values [list] + set hwidest 0 if {[tcl::dict::get $opts -headers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + if {$opt_colspan in {* unspecified}} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + } else { + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } } if {[tcl::dict::get $opts -data]} { if {[tcl::dict::exists $o_columndata $cidx]} { @@ -2847,9 +2965,10 @@ tcl::namespace::eval textblock { lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] } if {[llength $values]} { - set widest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set widest [expr {max($valwidest,$hwidest)}] } else { - set widest 0 + set widest $hwidest } return $widest } @@ -3143,24 +3262,43 @@ tcl::namespace::eval textblock { set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] set spaninfo [list] set numcols [tcl::dict::size $o_columndefs] - #note that 'all' can occur in positions other than column 0 - meaning all remaining + #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span tcl::dict::for {hrow rawspans} $spans_by_header { set thiscol_spanval [lindex $rawspans $cidx] - if {$thiscol_spanval eq "all" || $thiscol_spanval > 0} { + if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { set spanstartcol $cidx ;#own column - if {$thiscol_spanval eq "all"} { - set spanlen [expr {$numcols - $cidx}] + if {$thiscol_spanval eq "any"} { + #scan right to first non-zero to get actual length of 'any' span + #REVIEW! + set spanlen 1 + for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { + #abort at next any or number or empty string + if {[lindex $rawspans $i] ne "0"} { + break + } + incr spanlen + } + #set spanlen [expr {$numcols - $cidx}] } else { set spanlen $thiscol_spanval } } else { - #look left til we see an all or a non-zero value + #look left til we see an any or a non-zero value for {set i $cidx} {$i > -1} {incr i -1} { set s [lindex $rawspans $i] - if {$s eq "all" || $s > 0} { + if {$s eq "any" || $s > 0} { set spanstartcol $i - if {$s eq "all"} { - set spanlen [expr {$numcols - $i}] + if {$s eq "any"} { + #REVIEW! + #set spanlen [expr {$numcols - $i}] + set spanlen 1 + #now scan right to see how long the 'any' actually is + for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { + if {[lindex $rawspans $j] ne "0"} { + break + } + incr spanlen + } } else { set spanlen $s } @@ -3295,7 +3433,7 @@ tcl::namespace::eval textblock { set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] #JMN - #set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth @@ -3303,7 +3441,7 @@ tcl::namespace::eval textblock { } if {[llength $cols]} { - #return [textblock::join {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3399,11 +3537,11 @@ tcl::namespace::eval textblock { } else { set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol] - #set nextcol [textblock::join [textblock::block $padwidth $height $TSUB] $nextcol] + #set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] #JMN - #set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth @@ -3411,7 +3549,7 @@ tcl::namespace::eval textblock { } if {[llength $cols]} { - #return [textblock::join {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3517,7 +3655,7 @@ tcl::namespace::eval textblock { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] } lappend body_blocks $nextcol_body - #set body_build [textblock::join $body_build[unset body_build] $nextcol_body] + #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } incr padwidth $bodywidth incr colposn @@ -3605,18 +3743,29 @@ tcl::namespace::eval textblock { proc spantest {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] - $t configure_column 0 -header_colspans {3 4 5 all 2} + $t configure_column 0 -header_colspans {3 4 5 any 2} $t configure_column 2 -headers {"" "" "" "" c2span2_etc} $t configure_column 2 -header_colspans {0 0 0 0 2} $t configure -show_header 1 -ansiborder_header [a+ cyan] return $t } + proc spantest1 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] + $t configure_column 0 -header_colspans {any 4 any 5 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 0 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) + return $t + } #more complex colspans proc spantest2 {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} - $t configure_column 0 -header_colspans {3 4 1 all 2} + $t configure_column 0 -header_colspans {3 4 1 any 2} $t configure_column 1 -header_colspans {0 0 2 0 0} $t configure_column 2 -headers {"" "" "" "" c2span2} $t configure_column 2 -header_colspans {0 0 0 0 2} @@ -3625,9 +3774,9 @@ tcl::namespace::eval textblock { return $t } proc spantest3 {} { - set t [list_as_table -columns 5 -return tableobjec {a b c d e aa bb cc dd ee X Y}] + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} - $t configure_column 0 -header_colspans {3 4 1 all 2 1} + $t configure_column 0 -header_colspans {3 4 1 any 2 1} $t configure_column 1 -header_colspans {0 0 4 0 0 1} $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} $t configure_column 2 -headers {"" "" "" "" "" c2span2} @@ -4667,6 +4816,7 @@ tcl::namespace::eval textblock { # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner #" set argd [punk::args::get_dict { + -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto blocks -type any -multiple 1 } $args] @@ -4726,13 +4876,22 @@ tcl::namespace::eval textblock { -ansiresets { if {[lindex $args 2] eq "--"} { set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] } else { - set blocks [lrange $args 2 end] + error "end of opts marker -- is mandatory." } - set ansiresets [lindex $args 1] } default { - set blocks $args + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } } } @@ -4836,11 +4995,12 @@ tcl::namespace::eval textblock { proc example3 {{text "test\netc\nmore text"}} { package require patternpunk - .= textblock::join [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join " " |> .=>1 textblock::join $text |> .=>1 textblock::join [>punk . rhs] |> .=>1 textblock::join [punk::lib::list_as_lines -- [lrepeat 7 " | "]] + .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] } proc example2 {{text "test\netc\nmore text"}} { package require patternpunk .= textblock::join\ + --\ [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ [>punk . lhs]\ " "\ @@ -4900,67 +5060,96 @@ tcl::namespace::eval textblock { } variable frametypes - set frametypes [list light heavy arc double block block1 ascii altg] + set frametypes [list light heavy arc double block block1 block2 ascii altg] #class::table needs to be able to determine valid frametypes proc frametypes {} { variable frametypes return $frametypes } proc frametype {f} { - variable frametypes - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - if {$f ni $frametypes} { - set is_custom_dict_ok 1 - if {[llength $f] %2 == 0} { - #custom dict may leave out keys - but cannot have unknown keys - foreach {k v} $f { - switch -- $k { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - #k not in custom_keys - set is_custom_dict_ok 0 - break + switch -- $f { + light - heavy - arc - double - block - block1 - block2 - ascii - altg { + return [tcl::dict::create category predefined type $f] + } + default { + set is_custom_dict_ok 1 + if {[llength $f] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + foreach {k v} $f { + switch -- $k { + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + default { + #k not in custom_keys + set is_custom_dict_ok 0 + break + } } } + } else { + set is_custom_dict_ok 0 } - } else { - set is_custom_dict_ok 0 - } - if {!$is_custom_dict_ok} { - error "frame option -type must be one of known types: $frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $textblock::frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_frame [tcl::dict::merge $default_custom $f] + return [tcl::dict::create category custom type $custom_frame] } - set custom_frame [tcl::dict::merge $default_custom $f] - return [tcl::dict::create category custom type $custom_frame] - } else { - return [tcl::dict::create category predefined type $f] } } variable framedef_cache [tcl::dict::create] - proc framedef {f args} { + proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. variable framedef_cache - set cache_key [concat $f $args] + set cache_key $args if {[tcl::dict::exists $framedef_cache $cache_key]} { return [tcl::dict::get $framedef_cache $cache_key] } + set argopts [lrange $args 0 end-1] + set f [lindex $args end] + + #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path + #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. + #It also means we can't specify checks on the option types etc set opts [tcl::dict::create\ -joins ""\ -boxonly 0\ ] - foreach {k v} $args { + set bad_option 0 + foreach {k v} $argopts { switch -- $k { -joins - -boxonly { tcl::dict::set opts $k $v } default { - error "framedef unknown option '$k'. Known options [tcl::dict::keys $opts]" + set bad_option + break } } } + if {[llength $args] % 2 == 0 || $bad_option} { + #no framedef supplied, or unrecognised opt seen + set spec [string map [list $::textblock::frametypes] { + *proc -name textblock::framedef + -joins -default "" -help "List of join directions, any of: up down left right + or those combined with another frametype e.g left-heavy down-light" + -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements + It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" + *values -min 1 -max 1 + frametype -help "name from the predefined frametypes: + or an adhoc + }] + append spec \n "frametype -help \"A predefined \"" + punk::args::get_dict $spec $args + return + } + set joins [tcl::dict::get $opts -joins] set boxonly [tcl::dict::get $opts -boxonly] @@ -5986,6 +6175,7 @@ tcl::namespace::eval textblock { } } block1 { + #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported set hlt \u2581 ;# lower one eighth block set hlb \u2594 ;# upper one eighth block set vll \u258f ;# left one eighth block @@ -6002,17 +6192,19 @@ tcl::namespace::eval textblock { set vlrj $vlr } - blockxx { + block2 { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block - set vll \u2595 ;# right one eighth block - set vlr \u258f ;# left one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block - set tlc \u2595 ;# right one eighth block - set trc \u258f ;# left one eighth block + set tlc \U1fb7d ;#legacy block + set trc \U1fb7e ;#legacy block - set blc \u2595 ;# right one eighth block - set brc \u258f ;# left one eighth block + set blc \U1fb7c ;#legacy block + set brc \U1fb7f ;#legacy block #horizontal and vertical bar joins set hltj $hlt @@ -6039,36 +6231,36 @@ tcl::namespace::eval textblock { set vlrj $vlr } default { - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - set custom_frame [tcl::dict::merge $default_custom $f] - tcl::dict::with custom_frame {} ;#extract keys as vars - - if {[tcl::dict::exists $custom_frame hlt]} { - set hlt [tcl::dict::get $custom_frame hlt] - } else { - set hlt $hl + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing + if {[llength $f] % 2 != 0} { + #todo - retrieve usage from punk::args + error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $textblock::frametypes and does not appear to be a dictionary for a custom frametype" } - if {[tcl::dict::exists $custom_frame hlb]} { - set hlb [tcl::dict::get $custom_frame hlb] - } else { - set hlb $hl - } - - if {[tcl::dict::exists $custom_frame vll]} { - set vll [tcl::dict::get $custom_frame vll] - } else { - set vll $vl + #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults + dict for {k v} $f { + switch -- $k { + hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} + default { + error "textblock::frametype '$f' has unknown element '$k'" + } + } } - if {[tcl::dict::exists $custom_frame vlr]} { - set vlr [tcl::dict::get $custom_frame vlr] - } else { - set vlr $vl + #verified keys - safe to extract as vars + set custom_frame [tcl::dict::merge $default_custom $f] + tcl::dict::with custom_frame {} ;#extract keys as vars + #longer j vars must be after their more specific counterparts in the list being processed by foreach + foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { + if {[tcl::dict::exists $custom_frame $t]} { + set $t [tcl::dict::get $custom_frame $t] + } else { + #set more explicit type to it's more general counterpart if it's missing + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] + } } - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr + #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set + #horizontal and vertical bar joins - key/variable ends with 'j' } } if {$boxonly} { @@ -6270,7 +6462,7 @@ tcl::namespace::eval textblock { } } switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 {} + "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} default { set is_joins_ok 0 break @@ -6473,7 +6665,7 @@ tcl::namespace::eval textblock { set vll_width 1 ;#default for all except custom (printing width) set vlr_width 1 - set framedef [textblock::framedef $framedef -joins $opt_joins] + set framedef [textblock::framedef -joins $opt_joins $framedef] tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars #puts "---> $opt_boxmap" @@ -6932,9 +7124,9 @@ tcl::namespace::eval textblock { #Test we can join two coloured blocks proc test_colour {} { - set b1 [a= red]1\n2\n3[a=] - set b2 [a= green]a\nb\nc[a=] - set result [textblock::join $b1 $b2] + set b1 [a red]1\n2\n3[a] + set b2 [a green]a\nb\nc[a] + set result [textblock::join -- $b1 $b2] puts $result #return [list $b1 $b2 $result] return [ansistring VIEW $result]