diff --git a/src/make.tcl b/src/make.tcl index c0aeb9db..dbf6d7f9 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -1,4 +1,11 @@ +# tcl +# +#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. +#e.g in 'bin' and 'modules' folders at same level as 'src' folder. +#It is assumed the src folder has been placed somewhere where appropriate +#(e.g not in /usr or c:/ - unless you intend it to directly make and place folders and files in those locations) +package require punk::mix if {[lsearch $::argv -k] >= 0} { set forcekill 1 @@ -6,169 +13,183 @@ if {[lsearch $::argv -k] >= 0} { set forcekill 0 } puts stdout "::argv $::argv" - -set dirname [file normalize [file dirname [info script]]] - +set sourcefolder [file normalize [file dirname [info script]]] # ---------------------------------------- -proc copy_modules_in_dir {srcdir basedir {subdirlist {}}} { - set module_list [list] - set src_modules [glob -nocomplain -dir $srcdir -type f -tail *.tm] - if {![file exists $basedir]} { - error "copy_modules_in_dir basedir:'$basedir' doesn't exist" - } - if {[llength $subdirlist] == 0} { - set target_module_dir $basedir - } else { - set target_module_dir $basedir/[file join {*}$subdirlist] - } - foreach m $src_modules { - puts stdout "copying module $srcdir/$m to $target_module_dir" - file copy -force $srcdir/$m $target_module_dir - lappend module_list $srcdir/$m - } - set subdirs [glob -nocomplain -dir $srcdir -type d -tail *] - #puts stderr "subdirs: $subdirs" - foreach d $subdirs { - if {[string match "#*" $d] || ($d eq "_aside")} { - continue - } - if {![file exists $target_module_dir/$d]} { - file mkdir $target_module_dir/$d - } - lappend module_list {*}[copy_modules_in_dir $srcdir/$d $basedir [list {*}$subdirlist $d]] - } - return $module_list -} - -set target_modules_base [file dirname $dirname]/modules +set target_modules_base [file dirname $sourcefolder]/modules file mkdir $target_modules_base - -#external modules first -set copied [copy_modules_in_dir $dirname/deps $target_modules_base] +#external modules first - and any supporting files - no 'building' required +set copied [punk::mix::cli::lib::copy_files_from_source_to_base $sourcefolder/deps $target_modules_base -force 1] puts stderr "Copied [llength $copied] dependencies" -set src_module_dir $dirname/modules -#modules belonging to this package/app -set copied [copy_modules_in_dir $src_module_dir $target_modules_base] +set src_module_dir $sourcefolder/modules +#modules and associated files belonging to this package/app +set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm puts stderr "Copied [llength $copied] app modules" - -#set src_modules [glob -nocomplain -dir $src_module_dir -type f -tail *.tm] -#foreach m $src_modules { -# puts stdout "copying module $src_module_dir/$m to $target_module_dir" -# file copy -force $src_module_dir/$m $target_module_dir -#} +set copied [punk::mix::cli::lib::copy_nonmodules_from_source_to_base $src_module_dir $target_modules_base -force 1] # ---------------------------------------- -# -if {![file exists $dirname/punk86.vfs]} { - puts stderr "missing $dirname/punk86.vfs" - exit 1 -} -if {[file exists $dirname/punk86]} { - puts stderr "deleting existing $dirname/punk86" - file delete $dirname/punk86 -} -puts stdout "building with sdx.." -if {[catch { - exec sdx wrap punk86 -runtime tclkit86bi.exe -verbose - } result]} { - puts stderr "sdx wrap punk86 -runtime tclkit86bi.exe -verbose failed with msg: $result" -} else { - puts stdout "ok - finished sdx" - set separator [string repeat = 40] - puts stdout $separator - puts stdout $result - puts stdout $separator +set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] +if {![llength $vfs_folders]} { + puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" + puts stdout " -done- " + exit 0 } +file mkdir $sourcefolder/_build -if {![file exists $dirname/punk86]} { - puts stderr "|err> build didn't seem to produce output at $dirname/punk86" +if {[catch {exec sdx help} errM]} { + puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" + puts stderr "err: $errM" + exit 1 +} +#find runtime - only supports one for now.. REVIEW +set rtfolder $sourcefolder/runtime +set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] +if {![llength $runtimes]} { + puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." exit 2 } +if {[llength $runtimes] > 1} { + puts stderr "Found multiple runtimes in $rtfolder ($runtimes) - unable to proceed - currently limited to one." + exit 3 +} + +set runtimefile [lindex $runtimes 0] -if {![catch { - exec tasklist | grep punk86 - } still_running]} { - puts stdout "found punk86 instances still running\n" - set count_killed 0 - foreach ln [split $still_running \n] { - puts stdout " $ln" - set pid [lindex $ln 1] - if {$forcekill} { - set killcmd [list taskkill /F /PID $pid] - } else { - set killcmd [list taskkill /PID $pid] +puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." +foreach vfs $vfs_folders { + set vfsname [file rootname $vfs] + puts stdout " Processing vfs $sourcefolder/$vfs" + puts stdout " ------------------------------------" + + if {[file exists $sourcefolder/_build/$vfsname]} { + puts stderr "deleting existing $sourcefolder/_build/$vfsname" + file delete $sourcefolder/_build/$vfsname + } + + puts stdout "building $vfsname with sdx.." + + if {[catch { + exec sdx wrap _build/$vfsname -runtime runtime/$runtimefile -verbose + } result]} { + puts stderr "sdx wrap _build/$vfsname -runtime runtime/$runtimefile -verbose failed with msg: $result" + } else { + puts stdout "ok - finished sdx" + set separator [string repeat = 40] + puts stdout $separator + puts stdout $result + puts stdout $separator + } + + if {![file exists $sourcefolder/_build/$vfsname]} { + puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname" + exit 2 + } + + if {$::tcl_platform(platform) eq "windows"} { + set pscmd "tasklist" + } else { + set pscmd "ps" + } + + if {![catch { + exec $pscmd | grep $vfsname + } still_running]} { + puts stdout "found $vfsname instances still running\n" + set count_killed 0 + foreach ln [split $still_running \n] { + puts stdout " $ln" + + if {$::tcl_platform(platform) eq "windows"} { + set pid [lindex $ln 1] + if {$forcekill} { + set killcmd [list taskkill /F /PID $pid] + } else { + set killcmd [list taskkill /PID $pid] + } + } else { + set pid [lindex $ln 0] + #review! + if {$forcekill} { + set killcmd [list kill -9 $pid] + } else { + set killcmd [list kill $pid] + } + } + + puts stdout " pid: $pid (attempting to kill now using '$killcmd')" + + if {[catch { + exec {*}$killcmd + } errMsg]} { + puts stderr "$killcmd returned an error:" + puts stderr $errMsg + puts stderr "(try '[info script] -k' option to force kill)" + exit 4 + } else { + puts stderr "$killcmd ran without error" + incr count_killed + } } - - puts stdout " pid: $pid (attempting to kill now using '$killcmd')" - + if {$count_killed > 0} { + puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" + after 1000 + } + } else { + puts stderr "Ok.. no running '$vfsname' processes found" + } + + if {$::tcl_platform(platform) eq "windows"} { + set targetexe ${vfsname}.exe + } else { + set targetexe $vfsname + } + + if {[file exists $sourcefolder/_build/$targetexe]} { + puts stderr "deleting existing $sourcefolder/_build/$targetexe" if {[catch { - exec {*}$killcmd - } errMsg]} { - puts stderr "taskkill /PID $pid returned an error:" - puts stderr $errMsg - puts stderr "(try '[info script] -k' option to force kill)" + file delete $sourcefolder/_build/$targetexe + } msg]} { + puts stderr "Failed to delete $sourcefolder/_build/$targetexe" exit 4 - } else { - puts stderr "taskkill /PID $pid ran without error" - incr count_killed } } - if {$count_killed > 0} { - puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" - after 1000 - } -} else { - puts stderr "Ok.. no running punk processes found" -} + if {$::tcl_platform(platform) eq "windows"} { + file rename $sourcefolder/_build/$vfsname $sourcefolder/_build/${vfsname}.exe + } + after 200 + set deployment_folder [file dirname $sourcefolder]/bin + file mkdir $deployment_folder -if {[file exists $dirname/punk86.exe]} { - puts stderr "deleting existing $dirname/punk86.exe" - if {[catch { - file delete $dirname/punk86.exe - } msg]} { - puts stderr "Failed to delete $dirname/punk86.exe" - exit 3 + if {[file exists $deployment_folder/$targetexe]} { + puts stderr "deleting existing deployed at $deployment_folder/$targetexe" + if {[catch { + file delete $deployment_folder/$targetexe + } errMsg]} { + puts stderr "deletion of deployed version at $deployment_folder/$targetexe failed: $errMsg" + exit 5 + } } -} -#is this test necessary? -if {[file exists $dirname/punk86.exe]} { - puts stderr "deletion of $dirname/punk86.exe failed - locked?" - exit 3 -} -file rename $dirname/punk86 $dirname/punk86.exe -after 200 -set deployment_folder [file dirname $dirname] -if {[file exists $deployment_folder/punk86.exe]} { - puts stderr "deleting existing deployed at $deployment_folder/punk86.exe" - if {[catch { - file delete $deployment_folder/punk86.exe - } errMsg]} { - puts stderr "deletion of deployed version at $deployment_folder/punk86.exe failed: $errMsg" - exit 4 - } + puts stdout "copying.." + puts stdout "$sourcefolder/_build/$targetexe" + puts stdout "to:" + puts stdout "$deployment_folder/$targetexe" + after 500 + file copy $sourcefolder/_build/$targetexe $deployment_folder/$targetexe } - -puts stdout "copying.." -puts stdout "$dirname/punk86.exe" -puts stdout "to:" -puts stdout "$deployment_folder/punk86.exe" -after 500 -file copy $dirname/punk86.exe $deployment_folder/punk86.exe - puts stdout "done" +exit 0 diff --git a/src/modules/overtype-1.3.tm b/src/modules/overtype-1.4.tm similarity index 73% rename from src/modules/overtype-1.3.tm rename to src/modules/overtype-1.4.tm index 472bbb98..df63ddad 100644 --- a/src/modules/overtype-1.3.tm +++ b/src/modules/overtype-1.4.tm @@ -1,11 +1,12 @@ - -package provide [lassign {overtype 1.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] +package provide [lassign {overtype 1.4} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] #Julian Noble - 2003 #Released under standard 'BSD license' conditions. # #todo - ellipsis truncation indicator for center,right +#v1.4 2023-07 - naive ansi color handling - todo - fix string range +# - need to extract and replace ansi codes? namespace eval overtype { namespace export * @@ -14,6 +15,28 @@ proc overtype::about {} { return "Simple text formatting. Author JMN. BSD-License" } +proc overtype::stripcodes {text} { + if {[set posn [string first "\033\[" $text]] >= 0} { + set mnext [string first m [string range $text $posn end]] + if {$mnext >= 0} { + set mpos [expr {$posn + $mnext}] + set stripped1 [string range $text 0 $posn-1][string range $text $mpos+1 end] + #return [stripcodes $stripped1] ;#recurse to get any others + tailcall ::shellfilter::ansi::stripcodes $stripped1 + } else { + #partial or not actually an ansi code.. pass it all through + return $text + } + } else { + return $text + } +} + +#length of text for printing characters only +#review - unicode and other non-printing chars? +proc overtype::printing_length {str} { + string length [overtype::stripcodes $str] +} proc overtype::left {args} { # @c overtype starting at left (overstrike) @@ -30,8 +53,8 @@ proc overtype::left {args} { array set opt [lrange $args 0 end-2] - set len [string length $undertext] - set overlen [string length $overtext] + set len [printing_length $undertext] + set overlen [printing_length $overtext] set diff [expr {$overlen - $len}] if {$diff > 0} { if {$opt(-overflow)} { @@ -65,8 +88,8 @@ proc overtype::left2 {args} { array set opt [lrange $args 0 end-2] - set len [string length $undertext] - set overlen [string length $overtext] + set len [printing_length $undertext] + set overlen [printing_length $overtext] set diff [expr {$overlen - $len}] if {$diff > 0} { if {$opt(-overflow)} { @@ -94,8 +117,8 @@ proc overtype::centre {args} { array set opt [lrange $args 0 end-2] - set olen [string length $overtext] - set ulen [string length $undertext] + set olen [printing_length $overtext] + set ulen [printing_length $undertext] set diff [expr {$ulen - $olen}] if {$diff > 0} { set half [expr {round(int($diff / 2))}] @@ -137,8 +160,8 @@ proc overtype::right {args} { array set opt [lrange $args 0 end-2] - set olen [string length $overtext] - set ulen [string length $undertext] + set olen [printing_length $overtext] + set ulen [printing_length $undertext] if {$opt(-overflow)} { return [string range $undertext 0 end-$olen]$overtext diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 8d4877ff..8941c00b 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -20,6 +20,11 @@ namespace eval punk { } } +namespace eval punk::pipecmds { + #where to install proc/compilation artifacts for pieplines + namespace export * +} + #globals... some minimal global var pollution #punk's official silly test dictionary @@ -77,6 +82,7 @@ namespace eval punk { namespace import ::control::assert package require struct::list package require fileutil + #package require punk::lib #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) @@ -87,6 +93,7 @@ namespace eval punk { debug define punk.pipe.var debug define punk.pipe.args debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation + debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc #----------------------------------- @@ -100,6 +107,8 @@ namespace eval punk { debug off punk.pipe.args debug level punk.pipe.args 3 debug off punk.pipe.rep 2 + debug on punk.pipe.compile + debug level punk.pipe.compile 4 debug header "dbg> " @@ -266,6 +275,7 @@ namespace eval punk { #Assumption - char not in "(" ")" #for punk varspecs we use / as the separator proc _split_at_unbracketed_comma1 {varname} { + set re_headvar {(.+?)(?![^(]*\))(,.*)*$} set varname [string trimleft $varname ,] set varlist [list] @@ -326,8 +336,13 @@ namespace eval punk { scan $s %${p}s%s } proc _split_patterns {varspecs} { + set cmdname ::punk::pipecmds::split_patterns_$varspecs + if {$cmdname in [info commands $cmdname]} { + return [$cmdname] + } + set varlist [list] - set var_terminals [list "@" "/" "#"] + 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 @@ -361,14 +376,17 @@ namespace eval punk { set var $token set spec "" if {$first_term > 0} { - lassign [scan $token %${first_term}s%s] var spec + #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. + #lassign [scan $token %${first_term}s%s] var spec + set var [string range $token 0 $first_term-1] + set spec [string range $token $first_term end] ;#key section includes the terminal char which ended the var and starts the spec } else { if {$first_term == 0} { set var "" set spec $token } } - lappend varlist [list $var $spec] + lappend varlist [list [string trim $var] [string trim $spec]] set token "" set token_index -1 ;#reduce by 1 because , not included in next token set first_term -1 @@ -392,15 +410,19 @@ namespace eval punk { set var $token set spec "" if {$first_term > 0} { - lassign [scan $token %${first_term}s%s] var spec + #lassign [scan $token %${first_term}s%s] var spec + set var [string range $token 0 $first_term-1] + set spec [string range $token $first_term end] ;#key section includes the terminal char which ended the var and starts the spec } else { if {$first_term == 0} { set var "" set spec $token } } - lappend varlist [list $var $spec] + lappend varlist [list [string trim $var] [string trim $spec]] } + proc $cmdname {} [list return $varlist] + debug.punk.pipe.compile {proc $cmdname} 4 return $varlist } proc _split_var_key_at_unbracketed_comma {varspecs} { @@ -537,10 +559,9 @@ namespace eval punk { return $fun } - #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a tcl script proc destructure {selector data} { + #puts stderr ".d." set selector [string trim $selector /] - upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position set leveldata $data @@ -558,7 +579,7 @@ namespace eval punk { set lhs $subpath set assigned "" set get_not 0 - set already_assigned 0 + set already_assigned 0 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. @@ -582,6 +603,7 @@ namespace eval punk { set assigned [string length $leveldata] set already_assigned 1 } elseif {$index eq "@"} { + upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position 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 @@ -604,7 +626,7 @@ namespace eval punk { set already_assigned 1 } else { - if {$index in [list "@@" "@?@"]} { + if {$index in [list "@@" "@?@" "@??@"]} { 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 @@ -627,7 +649,11 @@ namespace eval punk { set keyindex [expr {$next_this_level -1}] if {($keyindex + 1) <= $dsize} { set k [lindex [dict keys $leveldata] $keyindex] - set assigned [list $k [dict get $leveldata $k]] + 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 @@ -658,6 +684,16 @@ namespace eval punk { set assigned [list] } set already_assigned 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 + if {[dict exists $leveldata $key]} { + set assigned [list $key [dict get $leveldata $key]] + } else { + set assigned [list] + } + set already_assigned 1 } elseif {[string match @* $index]} { set active_key_type "list" set do_bounds_check 1 @@ -696,7 +732,7 @@ namespace eval punk { #keyword 'pipesyntax' at beginning of error message set listmsg "pipesyntax Unable to interpret subindex $index\n" - append listmsg "selector: $selector\n" + append listmsg "selector: '$selector'\n" append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" append listmsg "Additional accepted keywords include: head tail\n" append listmsg "Use var@@key to treat value as a dict and retrieve element at key" @@ -763,6 +799,13 @@ namespace eval punk { break } set assigned [lrange $leveldata 1 end] + } elseif {$index eq "init"} { + #all but last element - same as haskell 'init' + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 0 end-1] } elseif {$index eq "list"} { #allow returning of entire list even if empty if {[catch {llength $leveldata} len]} { @@ -870,7 +913,7 @@ namespace eval punk { set assigned [lrange $leveldata $start $end] } } else { - error $listmsg + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } } elseif {[string first - $index] > 0} { if {[catch {llength $leveldata} len]} { @@ -883,7 +926,7 @@ namespace eval punk { #don't worry about leading - negative value for indices not valid anyway set parts [split $index -] if {[llength $parts] != 2} { - error $listmsg + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } lassign $parts start end if {$start+1 > $len || $end+1 > $len} { @@ -896,12 +939,12 @@ namespace eval punk { set assigned [lrange $leveldata $start $end] } } else { - error $listmsg + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } } else { #keyword 'pipesyntax' at beginning of error message - error $listmsg + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } } else { #treat as dict key @@ -930,175 +973,1021 @@ namespace eval punk { return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] } - #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level - #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope - #return a dict with keys result, setvars, unsetvars - #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar - #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) - #e.g x,x@0 will only match a single element list - #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" - #'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 - return [dict create ismatch 1 result $data setvars {} script {}] + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a tcl script + proc destructure_func {selector data} { + #puts stderr ".d." + set selector [string trim $selector /] + #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position + + set leveldata $data + set cmdname ::punk::pipecmds::destructure_$selector + if {$cmdname in [info commands $cmdname]} { + tailcall $cmdname $data } - set returndict [dict create ismatch 0 result "" setvars {}] - set script "" + + set script "proc $cmdname {leveldata} {" + append script \n [string map [list $selector] {set selector ""}] ;# script should only need for error msgs + set subindices [split $selector /] + 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 ""}] + set rhs "" + append script \n {set rhs ""} - set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] - set opts [dict merge $defaults $args] - set unset [dict get $opts -unset] - set lvlup [dict get $opts -levelup] - set get_mismatchinfo [dict get $opts -mismatchinfo] - #comma seems a natural choice to split varspecs, - #but also for list and dict subelement access - #/ normally indicates some sort of hierarchical separation - (e.g in filesytems) - #so / will indicate subelements e.g @0/1 for lindex $list 0 1 - #set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] - set valsource_key_list [_split_patterns $multivar] + set selector_script_complete 0 + if {![string length $selector]} { + append script \n { + set assigned $leveldata + set rhs $leveldata + set leveldata $assigned + } + set selector_script_complete 1 + } elseif {[string is digit -strict [join $subindices ""]]} { + #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" + #pure numeric keylist - put straight to lindex + # + #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ + #We will leave this as a syntax for different (more performant) behaviour + #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. + #TODO - review and/or document + # + #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. + #set assigned [lindex $leveldata {*}$subindices] + 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 + }] + #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]} { + #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 /] + 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 + } else { + set action ?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 + } + } else { + set selector_script_complete 0 + } - #first classify into var_returntype of either "pipeline" or "segment" - #segment returntype is indicated by leading % - #mutually exclusive - atom/pin - #set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin - #set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] - #0 - novar - #1 - atom ' - #2 - pin ^ - #3 - boolean & - #4 - integer - #5 - double - #6 - var - #7 - glob (no classifier and contains * or ?) - #8 - numeric + if {!$selector_script_complete} { - set var_class [list] - set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - set var_names [list] - set var_actions [list] - #set var_actions [lmap v $var_names {expr {[list $v "" ""]}}] - - set leading_classifiers [list "'" "&" "^" ] - set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] + 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 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 assigned "" + append script \n {set assigned ""} - set expected_values [list] - #set expected_values [lmap v $var_names {list $v "-" ""}] - #e.g {a = abc} {b set ""} - foreach v_key $valsource_key_list { - lassign $v_key v key - set vname $v ;#default - if {$v eq ""} { - lappend var_class [list $v_key 0] - lappend varspecs_trimmed $v_key - } else { - set firstchar [string index $v 0] - if {$firstchar in $leading_classifiers} { - if {$firstchar eq "'"} { - lappend var_class [list $v_key 1] - #set vname [string range $v 1 end] - lappend varspecs_trimmed [list $vname $key] - } elseif {$firstchar eq "^"} { - set classes [list 2] - set vname [string range $v 1 end] - set secondclassifier [string index $v 1] - if {$secondclassifier eq "&"} { - #pinned boolean - lappend classes 3 - set vname [string range $v 2 end] - } elseif {$secondclassifier eq "#"} { - #pinned numeric comparison instead of string comparison - lappend classes 8 - set vname [string range $v 2 end] - } elseif {$secondclassifier eq "*"} { - #pinned glob - lappend classes 7 - set vname [string range $v 2 end] + #got_not shouldn't need to be in script + set get_not 0 + + # 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 + } + } + 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 } - #todo - check for second tag - & for pinned boolean? - #consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. - #while we're at it.. pinned glob would be nice. ^* - #maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. - #These all limit the range of varnames permissible - which is no big deal. - lappend var_class [list $v_key $classes] - lappend varspecs_trimmed [list $vname $key] - } elseif {$firstchar eq "&"} { - #we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. - #ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans - #allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. - lappend var_class [list $v_key 3] - set vname [string range $v 1 end] - lappend varspecs_trimmed [list $vname $key] } + 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 + } else { + set assigned [lindex $leveldata $index] + } + } + #set assigned [lindex $leveldata $index] + set level_script_complete 1 } else { - if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { - lappend var_class [list $v_key 7] ;#glob - #leave vname as the full glob - lappend varspecs_trimmed [list "" $key] - } else { - set numtestv [join [scan $v %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 - #leading . still need to test directly for double - if {[string is double -strict $v] || [string is double -strict $numtestv]} { - if {[string is integer -strict $numtestv]} { - #this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired - #integer test before double.. - #note there is also string is wide (string is wideinteger) for larger ints.. - lappend var_class [list $v_key 4] - lappend varspecs_trimmed $v_key + if {$index in [list "@@" "@?@" "@??@"]} { + set active_key_type "dict" + append script \n {# set active_key_type "dict"} + append script \n {upvar v_dict_idx v_dict_idx} + + #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 + + # + #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 { - #double - #sci notation 1e123 etc - #also large numbers like 1000000000 - even without decimal point - (tcl bignum) - lappend var_class [list $v_key 5] - lappend varspecs_trimmed $v_key + 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 { - lappend var_class [list $v_key 6] ;#var - lappend varspecs_trimmed $v_key + 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] + } + }] } + + append script \n [string map [list $body] $subscript] + set level_script_complete 1 + + } 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 ] + } else { + set action ?mismatch-dict-key-not-found + } + }] + set level_script_complete 1 + } elseif {[string match {@\?@*} $index]} { + 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 ] + } else { + set assigned [list] + } + }] + 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 ]] + } 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 + }] + } else { + # } - } - } - lappend var_names $vname - lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version - lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from 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 + if {$index eq "not-tail"} { + append script \n {# set active_key_type "list"} + append script \n {set assigned [lindex $leveldata 0]} + set level_script_complete 1 + } elseif {$index in [list "not-head" "not-0"]} { + append script \n {# set active_key_type "list"} + append script \n {set assigned [lrange $leveldata 1 end]} + set level_script_complete 1 + } elseif {$index eq "not-end"} { + append script \n {# set active_key_type "list"} + append script \n {set assigned [lrange $leveldata 0 end-1]} + set level_script_complete 1 + } else { + #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" + } + } - #puts stdout "\n var_class: $var_class\n" - # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} - - #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] - #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" + } - #var names (possibly empty portion to the left of ) - #debug.punk.pipe.var "varnames: $var_names" 4 - set v_list_idx(@) 0 ;#for spec with single @ only - set v_dict_idx(@@) 0 ;#for spec with @@ only + if {!$level_script_complete} { - #jn + append script \n {if {$action eq "?match"}} " {" - #member lists of returndict which will be appended to in the initial value-retrieving loop - set returndict_setvars [dict get $returndict setvars] - - set assigned_values [list] + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + #append script \n [string map [list $listmsg] {set listmsg ""}] + - #varname action value - where value is value to be set if action is set - #actions: - # "" unconfigured - assert none remain unconfigured at end - # noop no-change - # matchvar-set name is a var to be matched + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + 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 + } 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] + } + } + } elseif {$index eq "end"} { + if {$do_bounds_check} { + append script \n { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } elseif {$len < 1} { + set action ?mismatch-list-index-out-of-range + } else { + set assigned [lindex $leveldata end] + } + } + } else { + append script \n { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + set assigned [lindex $leveldata end] + } + } + } + + } 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 + } else { + 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"} { + #allow returning of head or nothing if empty list + append script \n { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + set assigned [lindex $leveldata 0] + } + } + } 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 + } else { + set assigned [lrange $leveldata 1 end] + } + } + } 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 + } else { + set assigned [lrange $leveldata 0 end-1] + } + } + } 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 + } else { + set assigned $leveldata + } + } + } 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 + } else { + set assigned [dict keys $leveldata] + } + } + } 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 + } else { + set assigned [dict values $leveldata] + } + } + } elseif {$index eq "pairs"} { + append script \n { + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + } else { + set pairs [list] + dict for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } + } + } 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] + } + 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 + } 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 { + + } + }] + } + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + + 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} { + 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 { + + } + }] + } + + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + 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 + } + } + + 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 [string map [list $start] { + set start + if {$start+1 > $len} { + set action ?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 [string map [list $startoffset] { + set startoffset + if {abs($startoffset) >= $len} { + set action ?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 [string map [list $end] { + set end + if {$end+1 > $len} { + set action ?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 [string map [list $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]} { + + } + }] + + } 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 { + 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} { + 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 + } + }] + + } + + 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 + } + } + 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 + } + + + proc _var_classify {multivar} { + set cmdname ::punk::pipecmds::var_classify_$multivar + if {$cmdname in [info commands $cmdname]} { + return [$cmdname] + } + + + #comma seems a natural choice to split varspecs, + #but also for list and dict subelement access + #/ normally indicates some sort of hierarchical separation - (e.g in filesytems) + #so / will indicate subelements e.g @0/1 for lindex $list 0 1 + #set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] + set valsource_key_list [_split_patterns $multivar] + + + + #mutually exclusive - atom/pin + #set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin + #set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + #8 - numeric + #9 - > (+) + #10 - < (-) + + set var_names [list] + set var_class [list] + set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob + + + set leading_classifiers [list "'" "&" "^" ] + set trailing_classifiers [list + -] + set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] + + foreach v_key $valsource_key_list { + lassign $v_key v key + set vname $v ;#default + set classes [list] + if {$v eq ""} { + lappend var_class [list $v_key 0] + lappend varspecs_trimmed $v_key + } else { + set firstchar [string index $v 0] + set lastchar [string index $v end] + if {$lastchar eq "+"} { + lappend classes 9 + set vname [string range $v 0 end-1] + } + if {$lastchar eq "-"} { + lappend classes 10 + set vname [string range $v 0 end-1] + } + if {$firstchar in $leading_classifiers} { + if {$firstchar eq "'"} { + lappend var_class [list $v_key 1] + #set vname [string range $v 1 end] + lappend varspecs_trimmed [list $vname $key] + } elseif {$firstchar eq "^"} { + lappend classes [list 2] + #use vname - may already have trailing +/- stripped + set vname [string range $vname 1 end] + set secondclassifier [string index $v 1] + if {$secondclassifier eq "&"} { + #pinned boolean + lappend classes 3 + set vname [string range $v 2 end] + } elseif {$secondclassifier eq "#"} { + #pinned numeric comparison instead of string comparison + lappend classes 8 + set vname [string range $vname 1 end] + } elseif {$secondclassifier eq "*"} { + #pinned glob + lappend classes 7 + set vname [string range $v 2 end] + } + #todo - check for second tag - & for pinned boolean? + #consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. + #while we're at it.. pinned glob would be nice. ^* + #maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. + #These all limit the range of varnames permissible - which is no big deal. + lappend var_class [list $v_key $classes] + lappend varspecs_trimmed [list $vname $key] + } elseif {$firstchar eq "&"} { + #we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. + #ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans + #allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. + lappend var_class [list $v_key 3] + set vname [string range $v 1 end] + lappend varspecs_trimmed [list $vname $key] + } + + } else { + if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { + lappend var_class [list $v_key 7] ;#glob + #leave vname as the full glob + lappend varspecs_trimmed [list "" $key] + } else { + #scan vname not v - will either be same as v - or possibly stripped of trailing +/- + set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 + #leading . still need to test directly for double + if {[string is double -strict $vname] || [string is double -strict $numtestv]} { + if {[string is integer -strict $numtestv]} { + #this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired + #integer test before double.. + #note there is also string is wide (string is wideinteger) for larger ints.. + lappend classes 4 + lappend var_class [list $v_key $classes] + lappend varspecs_trimmed $v_key + } else { + #double + #sci notation 1e123 etc + #also large numbers like 1000000000 - even without decimal point - (tcl bignum) + lappend classes 5 + lappend var_class [list $v_key $classes] + lappend varspecs_trimmed $v_key + } + } else { + lappend var_class [list $v_key 6] ;#var + lappend varspecs_trimmed $v_key + } + } + } + + } + lappend var_names $vname + } + + set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] + + proc $cmdname {} [list return $result] + debug.punk.pipe.compile {proc $cmdname} + return $result + } + + + + #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level + #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope + #return a dict with keys result, setvars, unsetvars + #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar + #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) + #e.g x,x@0 will only match a single element list + #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" + #'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 + return [dict create ismatch 1 result $data setvars {} script {}] + } + set returndict [dict create ismatch 0 result "" setvars {}] + set script "" + + set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] + set opts [dict merge $defaults $args] + set unset [dict get $opts -unset] + set lvlup [dict get $opts -levelup] + set get_mismatchinfo [dict get $opts -mismatchinfo] + + + + #first classify into var_returntype of either "pipeline" or "segment" + #segment returntype is indicated by leading % + + set varinfo [_var_classify $multivar] + set var_names [dict get $varinfo var_names] + set var_class [dict get $varinfo var_class] + set varspecs_trimmed [dict get $varinfo varspecs_trimmed] + + set var_actions [list] + set expected_values [list] + #e.g {a = abc} {b set ""} + foreach classinfo $var_class vname $var_names { + lassign [lindex $classinfo 0] v + lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version + lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default + } + + #puts stdout "var_actions: $var_actions" + #puts stdout "expected_values: $expected_values" + + + #puts stdout "\n var_class: $var_class\n" + # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} + + #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] + #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" + + + #var names (possibly empty portion to the left of ) + #debug.punk.pipe.var "varnames: $var_names" 4 + + set v_list_idx(@) 0 ;#for spec with single @ only + set v_dict_idx(@@) 0 ;#for spec with @@ only + + #jn + + #member lists of returndict which will be appended to in the initial value-retrieving loop + set returndict_setvars [dict get $returndict setvars] + + set assigned_values [list] + + + #varname action value - where value is value to be set if action is set + #actions: + # "" unconfigured - assert none remain unconfigured at end + # noop no-change + # matchvar-set name is a var to be matched # matchatom-set names is an atom to be matched # matchglob-set # set @@ -1131,184 +2020,12 @@ namespace eval punk { #set v [lindex $var_names $i] #if v contains any * and/or ? - then it is a glob match - not a varname - #puts stdout "_____ _multi_bind_result rep assigned: [rep_listname assigned_values]" - if {[string length $vkey]} { - #if {[string is integer -strict $v]} { - # lset var_actions $i 1 matchatom - #} - - # if @# is found - remove the # and set a flag to indicate we are returning the length/size - # for @#@path - size of dict at the level specified by the path - - - - set vkey [string trimleft $vkey /] - - set subindices [split $vkey /] - if {[string is digit -strict [join $subindices ""]]} { - #puts stderr ">>>>>>>>>>>>>>>> data: $data vkey: $vkey subindices: $subindices" - #pure numeric keylist - put straight to lindex - # - #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ - #We will leave this as a syntax for different (more performant) behaviour - #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. - #TODO - review and/or document - # - #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. - set assigned [lindex $data {*}$subindices] - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - - - - } elseif {([scan $vkey %d-%d a b] == 2) && $vkey eq "${a}-${b}"} { - #pure digit range a-b - set assigned [lrange $data $a $b] - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } elseif {$vkey eq "0"} { - if {[catch {lindex $data 0} hd]} { - lset var_actions $i 1 ?mismatch-not-a-list - lset var_actions $i 2 $data - break - } - set assigned $hd - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } elseif {$vkey eq "head"} { - #head is never allowed to match empty list - (vs anyhead to allow) - if {[catch {lindex $data 0} hd]} { - lset var_actions $i 1 ?mismatch-not-a-list - lset var_actions $i 2 $data - break - } - if {[llength $data] == 0} { - lset var_actions $i 1 ?mismatch-list-index-out-of-range-empty - lset var_actions $i 2 $data - break - } - set assigned $hd - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } elseif {$vkey eq "#"} { - # always present as /# - / required to separate from @@# maining dict key "#" - also leading # would be a comment. - if {[catch {llength $data} len]} { - lset var_actions $i 1 ?mismatch-not-a-list - lset var_actions $i 2 $data - break - } - set assigned $len - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } elseif {$vkey eq "##"} { - # /## - if {[catch {dict size $data} dsize]} { - lset var_actions $i 1 ?mismatch-not-a-dict - lset var_actions $i 2 $data - break - } - set assigned $dsize - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } elseif {$vkey eq "#?"} { - set assigned [string length $data] - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } elseif {$vkey eq "@"} { - #no dict key following @, this is a positional spec for list - if {[catch {llength $data} len]} { - lset var_actions $i 1 ?mismatch-not-a-list - lset var_actions $i 2 $data - break - } - - if {$v_list_idx(@)+1 <= $len} { - set assigned [lindex $data $v_list_idx(@)] - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } else { - lset var_actions $i 1 ?mismatch-list-index-out-of-range - lset var_actions $i 2 $data - break - } - - #if {[string length $v]} { - # uplevel $lvlup [list set $v $assigned] - #} - incr v_list_idx(@) ;#only incr each time we have a plain @ at the root level of the index - } elseif {$vkey eq "@@"} { - if {[catch {dict size $data} dlen]} { - lset var_actions $i 1 ?mismatch-not-a-dict - lset var_actions $i 2 $data - set assigned "" - break - } - # @@ positional spec for dict - set k [lindex [dict keys $data] $v_dict_idx(@@)] - if {($v_dict_idx(@@) + 1) <= [dict size $data]} { - set assigned [list $k [dict get $data $k]] ;#return a list of the k,v pair at the current @@ index position - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - } else { - lset var_actions $i 1 ?mismatch-dict-index-out-of-range - lset var_actions $i 2 $data - set assigned "" - break - } - incr v_dict_idx(@@) - } elseif {[string match "@@*" $vkey]} { - #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc - set rawkeylist [split $vkey /] ;#first key retains @@ - may be just '@@' - set keypath [string range $vkey 2 end] - set keylist [split $keypath /] - 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. - if {[dict exists $data {*}$keylist]} { - set assigned [dict get $data {*}$keylist] - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - #if {[string length $v]} { - # uplevel $lvlup [list set $v $assigned] - #} - } else { - #deliberate inconsistency with lindex out of range setting var to empty string - we need to cause a pattern mismatch - lset var_actions $i 1 ?mismatch-dict-key-not-found - lset var_actions $i 2 $data - break - } - } else { - #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) - #process level by level - lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs - if {$matchaction eq "?match"} { - set matchaction "?set" - } - lset var_actions $i 1 $matchaction - #todo - destructure should return more than just assigned..(?) - lset var_actions $i 2 $assigned - } - - } else { - # varname@x where x is positive or negative integer or zero - use x as lindex - # or x is a range e.g 0-3 suitable for lrange - - lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs - if {$matchaction eq "?match"} { - set matchaction "?set" - } - lset var_actions $i 1 $matchaction - lset var_actions $i 2 $assigned - } - } else { - #no vkey - whole of RHS to be applied - set assigned $data - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned - #if {[string length $v]} { - # uplevel $lvlup [list set $v $data] - #} + lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs + if {$matchaction eq "?match"} { + set matchaction "?set" } + lset var_actions $i 1 $matchaction + lset var_actions $i 2 $assigned #update the setvars/unsetvars elements if {[string length $v]} { @@ -1373,12 +2090,14 @@ namespace eval punk { set isatom [expr {$class_key == 1}] set ispin [expr {2 in $class_key}] set isbool [expr {3 in $class_key}] - set isint [expr {$class_key == 4}] - set isdouble [expr {$class_key == 5}] + 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}] @@ -1482,6 +2201,10 @@ namespace eval punk { } else { set lhs $lhsspec ;#literal integer in the pattern } + if {$isgreaterthan || $islessthan} { + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } if {[string index $lhs 0] eq "."} { set testlhs $lhs } else { @@ -1493,23 +2216,60 @@ namespace eval punk { set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) } if {[string is integer -strict $testval]} { - if {$testlhs == $testval} { - lset match_state $i 1 + if {$isgreaterthan} { + #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] + break + } } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] - break + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] + break + } } } elseif {[string is double -strict $testval]} { #dragons. (and shimmering) if {[string first "e" $val] != -1} { #scientific notation - let expr compare - if {$testlhs == $testval} { - lset match_state $i 1 + if {$isgreaterhthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] + break + } } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] - break + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] + break + } } } elseif {[string is digit -strict [string trim $val -]] } { #probably a wideint or bignum with no decimal point @@ -1521,20 +2281,56 @@ namespace eval punk { #string comparison can presumably always be used as an alternative. # #let expr compare - if {$testlhs == $testval} { - lset match_state $i 1 + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] + break + } } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] - break + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] + break + } } } else { if {[punk::float_almost_equal $testlhs $testval]} { lset match_state $i 1 } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] - break + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] + break + } + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] + break + } } } } else { @@ -1549,12 +2345,19 @@ namespace eval punk { } } elseif {$isdouble} { #dragons (and shimmering) + # + # if {$ispin} { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] } else { set lhs $lhsspec ;#literal integer in the pattern } + if {$isgreaterthan || $islessthan} { + error "+/- not yet supported for lhs float" + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } if {[string index $val 0] eq "."} { set testval $val ;#not something with some number of leading zeros } else { @@ -1634,7 +2437,8 @@ namespace eval punk { #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. set tclvar $lhs if {[string is double $tclvar]} { - error "pipesyntax invalid variable name '$tclvar' in pattern. (subset of legal tcl vars allowed in pattern context)" + error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] + #proc _multi_bind_result {multivar data args} } #treat as variable - need to check cross-binding within this pattern group set first_bound [lsearch -index 0 $var_actions $lhsspec] @@ -1802,7 +2606,7 @@ namespace eval punk { set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] set msg "\n" append msg "Unmatched\n" - append msg "No match of right hand side for vars in $multivar\n" + append msg "Cannot match right hand side to pattern $multivar\n" append msg "vars/atoms/etc: $var_names\n" append msg "mismatches: [join $mismatches_display { } ]\n" set i 0 @@ -1866,10 +2670,11 @@ namespace eval punk { return $returndict } - if {![llength $valsource_key_list]} { + if {![llength $var_names]} { + #var_name entries can be blank - but it will still be a list dict set returndict result $data } else { - #punk::assert {$i == [llength $valsource_key_list]} + #punk::assert {$i == [llength $var_names]} dict set returndict result $returnval } @@ -1877,7 +2682,7 @@ namespace eval punk { } ######################################################## - # serious dragons. + # dragons. # using an error as out-of-band way to signal mismatch is the easiest. # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. @@ -1890,7 +2695,8 @@ namespace eval punk { #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 if {![dict exists $d result]} { #uplevel 1 [list error [dict get $d mismatch]] - error [dict get $d mismatch] + #error [dict get $d mismatch] + return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] } else { return [dict get $d result] } @@ -1930,7 +2736,29 @@ namespace eval punk { variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} #match_assign is tailcalled from unknown - uplevel 1 gets to caller level proc match_assign {scopepattern equalsrhs args} { + + #review - :: is legal in atoms! + if {[string match "*::*" $scopepattern]} { + error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." + } + puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" set fulltail $args + set homens ::punk::pipecmds + + set pipecmd ${homens}::$scopepattern=$equalsrhs + #pipecmd could have glob chars - test $pipcmd in the list - not just that info commands returns results. + if {$pipecmd in [info commands $pipecmd]} { + #puts "==nscaller: '[uplevel 1 [list namespace current]]'" + uplevel 1 [list namespace import $pipecmd] + tailcall $pipecmd {*}$args + } + + + #NOTE: + #we need to ensure for case: + #= x=y + #that the second arg is treated as a raw value - never a pipeline command + #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. @@ -1949,17 +2777,16 @@ namespace eval punk { #all pipe operators must be a single element foreach a $args { if {![catch {llength $a} sublen]} { - if {$sublen == 1} { - if {[string match |*> $a] || [string match <*| $a]} { - tailcall punk::pipeline = "" "" {*}$args - } + #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} + if {[string match |*> $a] || [string match <*| $a]} { + tailcall punk::pipeline = "" "" {*}$args } } } if {[llength $args] == 1} { set segmenttail [lindex $args 0] } else { - error "pipesyntax = must take a single argument" + error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =] } } else { #set segmenttail [purelist] @@ -1974,7 +2801,7 @@ namespace eval punk { # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. # We are probably only here if testing in the repl - in which case the error messages are important. - set var_position_list [_split_equalsrhs $equalsrhs] + 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 # we won't examine for vars as there is no pipeline - ignore @@ -1987,56 +2814,75 @@ namespace eval punk { - foreach v_pos $var_position_list { - lassign $v_pos v positionspec - if {[string index $v 0] eq "'"} { - set positionspec [string trimright $positionspec "*"] - set ptype [string index $positionspec 0] - set index [string range $positionspec 1 end] - set isint [string is integer -strict $index] - if {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { - set v [string range $v 1 end-1] ;#assume trailing ' is present! - if {$ptype eq "@"} { - #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) - if {$isint} { - append script [string map [list $index] { - if {( > [llength $segmenttail])} { - error "insertionpattern index out of bounds. index: vs len: [llength $segmenttail] use /x instead of @x to avoid check" - } - }] - } - #todo check end-x bounds? - } - if {$isint} { - #set segmenttail [linsert $segmenttail $index+$offset $v] ?? (offset concept is dubious) - # - append script [string map [list $v $index] { - #set segmenttail [linsert $segmenttail ] - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] - }] - } else { - #set segmenttail [linsert $segmenttail $idx $v] - append script [string map [list $v $index] { - #set segmenttail [linsert $segmenttail ] - #use inline K to make sure the list is unshared (optimize for larger lists) - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] - }] + foreach v_pos $var_index_position_list { + lassign $v_pos v indexspec positionspec + #e.g =v1/1>0 A $value $start $end] { - set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] ] - }] - } else { - error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" - } - } else { - error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" - } + #in this point of an assign (= as opposed to .=) IF we have already determined there is no trailing pipeline + #There will therefore be no variable names active in the pipeline's scope. + #This is ok, given that we can more easily inject directly from calling scope + #eg out= list a $callervar c + #or alternatively use .= instead + # + #HOWEVER - we need to build/compile a script that could then have further pipeline elements supplied as arguments + #At the moment - this is handled in the script above by diverting to punk::pipeline to handle + #The only vars/data we can possibly have to insert, come from the pattern predator system) + # + #todo - review + # + # + #for now - the script only needs to handle the case of a single segment pipeline (no |> <|) + + + #temp - needs_insertion + #we can safely output no script for variable insertions for now - because if there was data available, + #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. + #tag: positionspechandler + if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { + #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense + #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" + #review + if {[string length $indexspec]} { + error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] + } + if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { + set datasource [string range $v 1 end-1] + } elseif {[string is integer -strict $v]} { + set datasource $v + } + append script [string map [list $datasource] { + set insertion_data + }] + + set needs_insertion 1 + } elseif {$v eq ""} { + #default variable is 'data' + set needs_insertion 0 + } else { + append script [string map [list $v] { + #uplevel? + #set insertion_data [set ] + }] + set needs_insertion 0 } + if {$needs_insertion} { + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append script $script2 + } + + } @@ -2054,32 +2900,172 @@ namespace eval punk { #maintenance: inlined if {![dict exists $d result]} { #uplevel 1 [list error [dict get $d mismatch]] - error [dict get $d mismatch] + #error [dict get $d mismatch] + return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] } else { return [dict get $d result] } }] } - uplevel 1 [list proc $scopepattern=$equalsrhs args $script] - tailcall $scopepattern=$equalsrhs {*}$args + debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 + uplevel 1 [list proc $pipecmd args $script] + uplevel 1 [list namespace import $pipecmd] + tailcall $pipecmd {*}$args } + #return a script for inserting data into listvar + proc list_insertion_script {keyspec listvar {data }} { + set positionspec [string trimright $keyspec "*"] + set do_expand [expr {[string index $keyspec end] eq "*"}] + if {$do_expand} { + set exp {{*}} + } else { + set exp "" + } + #NOTE: linsert and lreplace can take multiple values at tail ie expanded data + set ptype [string index $positionspec 0] + if {$ptype in [list @ /]} { + set index [string range $positionspec 1 end] + } else { + #the / is optional (default) at first position - and we have already discarded the ">" + set ptype "/" + set index $positionspec + } + #puts stderr ">> >> $index" + set script "" + set isint [string is integer -strict $index] + if {$index eq "."} { + #do nothing - this char signifies no insertion + } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { + if {$ptype eq "@"} { + #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + if {$isint} { + append script [string map [list $listvar $index] { + if {( > [llength $])} { + #not a pipesyntax error + error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] + } + }] + } + #todo check end-x bounds? + } + if {$isint} { + append script [string map [list $listvar $index $exp $data] { + set [linsert [lindex [list $ [unset ]] 0] ] + }] + } else { + append script [string map [list $listvar $index $exp $data] { + #use inline K to make sure the list is unshared (optimize for larger lists) + set [linsert [lindex [list $ [unset ]] 0] ] + }] + + } + } elseif {[string first / $index] < 0 && [string first - $index] > 0} { + if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #also - range checks for @ which must go into script !!! + append script [string map [list $listvar $start $end $exp $data] { + set [lreplace [lindex [list $ [unset ]] 0] ] + }] + } else { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] + } + } elseif {[string first / $index] >= 0} { + #nested insertion e.g /0/1/2 /0/1-1 + set parts [split $index /] + set last [lindex $parts end] + if {[string first - $last] >=0} { + lassign [split $last -] a b + if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + if {$a eq $b} { + if {!$do_expand} { + #we can do an lset + set lsetkeys [list {*}[lrange $parts 0 end-1] $a] + append script [string map [list $listvar $lsetkeys $data] { + lset + }] + } else { + #we need to lreplace the containing item + append script [string map [list $listvar [lrange $parts 0 end-1] $a $data] { + set target [lindex $ ] + lset target {*} + lset $target + }] + } + } else { + #we need to lreplace a range at the target level + append script [string map [list $listvar [lrange $parts 0 end-1] $a $b $exp $data] { + set target [lindex $ ] + set target [lreplace $target ] + lset $target + }] + } + } else { + #last element has no -, so we are inserting at the final position - not replacing + append script [string map [list $listvar [lrange $parts 0 end-1] $last $exp $data] { + set target [lindex $ ] + set target [linsert $target ] + lset $target + }] + } + + + } else { + error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + return $script + } - #pattern for insertion position in the pipeline segment (*not* for insertion within any data elements themselves) - #With the =/assign operator - it does effectively insert into the data at top list level only. probably best to keep it that way - keep it simple. - #deeper data manipulations best kept for functions in the pipeline. - #This is primarily for the .= case. Allowing for example: - # x= a b c d |> .=@2 lsearch -inline b* - # to substitute to lsearch -inline {a b c d} b* + + + #todo - consider whether we can use < for insertion/iteration combinations + # =a<,b< iterate once through + # =a><,b>< cartesian product + # =a<>,b<> ??? zip ? + # + # ie = {a b c} |> .=< inspect + # would call inspect 3 times, once for each argument + # .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list + # would produce list of cartesian pairs? + # proc _split_equalsrhs {insertionpattern} { - set var_position_list [punk::_split_patterns $insertionpattern] + set cmdname ::punk::pipecmds::split_rhs_$insertionpattern + if {$cmdname in [info commands $cmdname]} { + return [$cmdname] + } + + set lst_var_indexposition [punk::_split_patterns $insertionpattern] set i 0 - foreach v_pos $var_position_list { - lassign $v_pos v positionspec - if {($positionspec in [list "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { + set return_triples [list] + foreach v_pos $lst_var_indexposition { + lassign $v_pos v index_and_position + #e.g varname@@data/ok>0 varname/1/0>end + #ensure only one ">" is detected + if {![string length $index_and_position]} { + set indexspec "" + set positionspec "" + } else { + set chars [split $index_and_position ""] + set posns [lsearch -all $chars ">"] + if {[llength $posns] > 1} { + error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] + } + if {![llength $posns]} { + set indexspec $index_and_position + set positionspec "" + } else { + set splitposn [lindex $posns 0] + set indexspec [string range $index_and_position 0 $splitposn-1] + set positionspec [string range $index_and_position $splitposn+1 end] + } + } + + #review - + if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { set star "" if {$v eq "*"} { set v "" @@ -2090,21 +3076,28 @@ namespace eval punk { } #it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent #as are /end and @end - lset var_position_list $i [list $v "/end$star"] + #lset lst_var_indexposition $i [list $v "/end$star"] + set triple [list $v $indexspec "/end$star"] } else { if {$positionspec eq ""} { - error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" - } - if {[string index $positionspec 0] ni [list "/" "@"]} { - error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad position spec '$positionspec'" + #e.g just =varname + #lset lst_var_indexposition $i [list $v "/end"] + set triple [list $v $indexspec "/end"] + #error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" + } else { + if {[string index $indexspec 0] ni [list "" "/" "@"]} { + error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] + } + set triple [list $v $indexspec $positionspec] } } + lappend return_triples $triple incr i } - return $var_position_list + proc $cmdname {} [list return $return_triples] + return $return_triples } - proc _is_math_func_prefix {e1} { #also catch starting brackets.. e.g "(min(4,$x) " if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { @@ -2118,15 +3111,15 @@ namespace eval punk { #todo - option to disable these traces which provide clarifying errors (performance hit?) proc pipeline_args_read_trace_error {args} { - error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." + error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] } - #REVIEW! the whole idea of scanning for %x% is a lot of work(performance penalty) + #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 #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) + # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) # #detect and retrieve %xxx% elements from item without affecting list/string rep #commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) @@ -2239,7 +3232,7 @@ namespace eval punk { proc pipeline {segment_op initial_returnvarspec equalsrhs args} { set fulltail $args - unset args + #unset args ;#leave args in place for error diagnostics debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 #debug.punk.pipe.rep {[rep_listname fulltail]} 6 @@ -2259,9 +3252,9 @@ namespace eval punk { } elseif {$next1 eq "pipecase"} { set msg "pipesyntax\n" append msg "pipecase does not return a value directly in the normal way\n" - append msg "It will return an {error {mismatch }} dict on mismatch\n" - append msg "But on a successful match - it will return {ok result {something}} in the caller's scope -\n" - append msg "which will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" + append msg "It will return a casemismatch dict on mismatch\n" + append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" + append msg "This will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." error $msg } @@ -2271,30 +3264,47 @@ namespace eval punk { + #NOTE: + #important that for assignment: + #= x=y .. + #The second element is always treated as a raw value - not a pipeline instruction. + #whereas... for execution: + #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. + #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - + #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway + #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines + # + if {$segment_op ne "="} { + #handle for example: + #var1.= var2= "etc" |> string toupper + # + #var1 will contain ETC, var2 will contain etc + # + if {([string first = $next1] >= 0) && (![arg_is_script_shaped $next1]) } { + #*SUB* pipeline recursion. + #puts "======> recurse based on next1:$next1 " + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $next1 _ nextreturnvarspec nextrhs]} { + #non pipelined call to self - return result + #debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 + #set results [uplevel 1 [list ::punk::pipeline .= $nextreturnvarspec $nextrhs {*}$nexttail]] + set results [uplevel 1 [list $next1 {*}$nexttail]] + + #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 + #debug.punk.pipe {>>> results: $results} 1 + return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] + } - if {([string first = $next1] >= 0) && (![arg_is_script_shaped $next1]) } { - #puts "======> recurse based on next1:$next1 " - #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} - if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $next1 _ nextreturnvarspec nextrhs]} { - #non pipelined call to self - return result - #debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 - #set results [uplevel 1 [list ::punk::pipeline .= $nextreturnvarspec $nextrhs {*}$nexttail]] - set results [uplevel 1 [list $next1 {*}$nexttail]] - - #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 - #debug.punk.pipe {>>> results: $results} 1 - return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] - } - - #puts "======> recurse asssign based on next1:$next1 " - if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { - #non pipelined call to plain = assignment - return result - #debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 - #set results [uplevel 1 [list ::punk::pipeline = $nextreturnvarspec $nextrhs {*}$nexttail]] - set results [uplevel 1 [list $next1 {*}$nexttail]] - #debug.punk.pipe {>>> results: $results} 1 - set d [_multi_bind_result $initial_returnvarspec $results] - return [_handle_bind_result $d] + #puts "======> recurse asssign based on next1:$next1 " + if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { + #non pipelined call to plain = assignment - return result + #debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 + #set results [uplevel 1 [list ::punk::pipeline = $nextreturnvarspec $nextrhs {*}$nexttail]] + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe {>>> results: $results} 1 + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } } } @@ -2320,26 +3330,31 @@ namespace eval punk { #e.g x.= func a b c |> transform x y z =0} { - set apipe_posn [expr {[llength $fulltail] - $apipe_posn_reverse -1}] - set tailremaining [lrange $fulltail 0 $apipe_posn-1] - set argslist [lrange $fulltail $apipe_posn+1 end] - set argpipe [lindex $fulltail $apipe_posn] - set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from "=0} { + set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] + set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. + set argpipe [lindex $fulltail $firstargpipe_posn] + set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " 1} { - error "pipesyntax 1 = can only accept a single argument" + error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] + #proc pipeline {segment_op initial_returnvarspec equalsrhs args} } set segment_members $segment_first_word } @@ -2505,122 +3521,84 @@ namespace eval punk { debug.punk.pipe.var {processing insertion_pattern dict_tagval: $dict_tagval} 4 set segment_members_filled [list] set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign - foreach v_pos $insertion_patterns { - lassign $v_pos v positionspec ;#v may be atom, or varname (in pipeline scope) - #julz - if {[string index $v 0] eq "'"} { - set v [string range $v 1 end-1] ;#assume trailing ' is present! - set getv $v - } else { - if {$v eq ""} { - set v "data" - } - if {[dict exists $dict_tagval $v]} { - set v [dict get $dict_tagval $v] - set getv "\$$v" - } else { - error "insertionpattern varname $v not present in pipeline context" - } - } - #append script [string map [list $getv]{ - # - #}] - #maintenance - index logic should be identical to to match_assign - which only needs to process atoms because it delegates all pipeline ops here, so no vars available (single segment assign) - set positionspecatomic [string trimright $positionspec "*"] - set do_expand [expr {[string index $positionspec end] eq "*"}] ;#only applies to vars - as atoms don't have whitespace (review a proc can have whitespce - but it's harder to call.. atoms probably best kept simple) - set ptype [string index $positionspecatomic 0] - set index [string range $positionspecatomic 1 end] - set isint [string is integer -strict $index] - if {$index eq "."} { - #blocking insertion-spec - explicit instruction not to pass this var in. - #most useful as just /. or data/. somevar/. is equivalent to leaving out the somevar insertionspec - #do nothing - no script - } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { - if {$ptype eq "@"} { - #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) - if {$isint} { - append script [string map [list $index] { - if {( > [llength $segmenttail])} { - error "insertionpattern index out of bounds. index: vs len: [llength $segmenttail] use /x instead of @x to avoid check" - } - }] - #temp - scriptalternative - if {($index > [llength $segmenttail])} { - error "insertionpattern index out of bounds. index:$index vs len: [llength $segmenttail] use /x instead of @x to avoid check" - } + + + set cmdname "::punk::pipecmds::insertion_$rhs" + #commandname can contain glob chars - must search for exact membership in 'info commands' result. + if {$cmdname ni [info commands $cmdname]} { + + set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" + foreach v_pos $insertion_patterns { + #puts stdout "v_pos '$v_pos'" + lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) + #puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" + #julz + + append insertion_script \n [string map [list $v_pos] { + lassign [list ] v indexspec positionspec + }] + + if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { + set v [string range $v 1 end-1] ;#assume trailing ' is present! + if {[string length $indexspec]} { + error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] } - #todo check end-x bounds? - } - if {$isint} { - #todo - expansion! - append script [string map [list $getv $index] { - #set segmenttail [linsert $segmenttail ] - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] - }] - #temp - scriptalternative - if {$do_expand} { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index {*}$v] - } else { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index $v] + append insertion_script \n "set insertion_data $v" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) + } elseif {[string is double -strict $v]} { + #don't treat numbers as variables + if {[string length $indexspec]} { + error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] } + append insertion_script \n {set insertion_data $v} } else { - #set segmenttail [linsert $segmenttail $idx $v] - #todo - expansion! - append script [string map [list $getv $index] { - #set segmenttail [linsert $segmenttail ] - #use inline K to make sure the list is unshared (optimize for larger lists) - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] + + append insertion_script \n [string map [list $cmdname] { + #puts ">>> v: $v dict_tagval:'$dict_tagval'" + if {$v eq ""} { + set v "data" + } + if {[dict exists $dict_tagval $v]} { + set insertion_data [dict get $dict_tagval $v] + #todo - use destructure_func + set d [punk::_multi_bind_result $indexspec $insertion_data] + set insertion_data [punk::_handle_bind_result $d] + } else { + #review - skip error if varname is 'data' ? + #e.g we shouldn't really fail for: + #.=>* list a b c <| + #we need to be careful not to insert empty-list as an argument by default + error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] + } + }] - #temp - scriptalternative - if {$do_expand} { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index {*}$v] - } else { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index $v] - } } - } elseif {[string first - $index] >= 0} { - if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { - #dragons? - #julz - #also - range checks for @ which must go into script !!! - #todo - disallow disordered specs such as: end-1-end-5 even though lreplace seems to accept them - - #TESTS! - #atoms? - if {$do_expand} { - set val {{*}} - append val $getv - } else { - set val $getv - } - append script [string map [list $getv $start $end] { - set rangelen [llength [lrange ]] - }] - set rangelen [llength [lrange $v $start $end]] - append script [string map [list $val $start $end] { - set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] ] - }] - if {$do_expand} { - #todo - - set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] $start $end {*}$v] - } else { - set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] $start $end $v] - } + #append script [string map [list $getv]{ + # + #}] + #maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) + #tag: positionspechandler + #puts stdout "=== list_insertion_script '$positionspec' segmenttail " + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append insertion_script \n $script2 - } else { - error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" - } - } else { - error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" - } + } + append insertion_script \n {set segmenttail} + append insertion_script \n "}" + #puts stderr "$insertion_script" + debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion_$rhs } 4 + eval $insertion_script } - set segment_members_filled $segmenttail + + set segment_members_filled [::punk::pipecmds::insertion_$rhs $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0] ] + + #set segment_members_filled $segmenttail #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) } @@ -2713,18 +3691,18 @@ namespace eval punk { } debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 - set ns [uplevel 1 {namespace current}] + set ns [uplevel 1 {::namespace current}] if {!$add_argsdata} { debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 #puts stderr " script: $script" #puts stderr " vals: $segmentargvals" - set evaluation [uplevel 1 [list apply [list $segmentargnames $script $ns] {*}$segmentargvals]] + set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] } else { debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 #puts stderr " script: $script" #puts stderr " vals: $segmentargvals $argsdatalist" #pipeline script context should be one below calling context - so upvar v v will work - set evaluation [uplevel 1 [list apply [list [concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] + set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] } debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 @@ -2857,7 +3835,8 @@ namespace eval punk { #never scripts #must be at most a single element after the = ! if {[llength $next_all_members] > 2} { - error "pipesyntax - at most one element can follow =" + #raise this as pipesyntax as opposed to pipedata? + error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] } set segment_first_word [lindex $next_all_members 1] if {[catch {llength $segment_first_word}]} { @@ -2916,6 +3895,7 @@ namespace eval punk { } + #just an experiment #what advantage/difference versus [llength [lrange $data $start $end]] ??? proc data_range_length {data start end} { set datalen [llength $data] @@ -2980,10 +3960,10 @@ namespace eval punk { proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { #--------------------------------------- if {![catch {expr {@c@}} res] && $res} { - debug.punk.unknown {HANDLED BY: punk unknown_handler args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 return [eval {@b@}] } else { - debug.punk.unknown {skipped: punk unknown_handler args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 } #--------------------------------------- }]$existing @@ -3046,18 +4026,59 @@ namespace eval punk { know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0 0] -> from to]} {punk::range $from $to} - proc ::punk::_unknown_assign_dispatch {partzerozero pattern equalsrhs args} { + #NOTE: + #we don't allow setting namespace qualified vars in the lhs assignment pattern. + #The principle is that we shouldn't be setting vars outside of the immediate calling scope. + #(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) + #Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever + #We will require that the namespace already exists - which is consistent with if the command were to be run without unknown + proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { set tail [lassign $args hd] #puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" - if {$hd ne $partzerozero} { + if {$hd ne $matchedon} { if {[llength $tail]} { error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" } #regexp $punk::re_assign $hd _ pattern equalsrhs #we assume the whole pipeline has been provided as the head - regexp {^([^ \t\r\n=\{]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail + regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail + } + #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah + # we only look at leftmost namespace-like thing and need to take account of the pattern syntax + # e.g for ::etc,'::x'= + # the ns is :: and the tail is etc,'::x'= + # (Tcl's namespace qualifiers/tail won't help here) + if {[string match ::* $hd]} { + set patterns [punk::_split_patterns $hd] + #get a pair-list something like: {::x /0} {etc {}} + set ns [namespace qualifiers [lindex $patterns 0 0]] + set nslen [string length $ns] + set patterntail [string range $ns $nslen end] + } else { + set ns "" + set patterntail $pattern + } + if {[string length $ns] && ![namespace exists $ns]} { + error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" + } else { + set nscaller [uplevel 1 [list ::namespace current]] + set commands [uplevel 1 [list ::info commands $pattern=$equalsrhs]] ;#uplevel - or else we are checking from perspective of this namespace ::punk + #we must check for exact match of the command in the list - because command could have glob chars. + if {"$pattern=$equalsrhs" in $commands} { + puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" + #we call the namespaced function - we don't evaluate it *in* the namespace. + #REVIEW + #warn for now...? + #tailcall $pattern=$equalsrhs {*}$args + tailcall $pattern=$equalsrhs {*}$tail + } } - tailcall ::punk::match_assign $pattern $equalsrhs {*}$tail + #puts "--->nscurrent [uplevel 1 [list namespace current]]" + #ignore the namespace.. + #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. + #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. + #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created + tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] } #variable re_assign {^([^\r\n=\{]*)=(.*)} @@ -3066,7 +4087,9 @@ namespace eval punk { #e.g x=a\nb c #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained # - know {[regexp {^([^ \t\r\n=\{]*)\=([^ \t\r\n]*)} [lindex $args 0 0] partzerozero pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $partzerozero $pattern $equalsrhs {*}$args} + know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} #variable re_assign {^([^\r\n=\{]*)=(.*)} #know {[regexp $punk::re_assign [lindex $args 0 0] partzerozero varspecs rhs]} { @@ -3133,6 +4156,7 @@ namespace eval punk { } #regexp $punk::re_assign $hd _ pattern equalsrhs #we assume the whole pipeline has been provided as the head + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail } #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail @@ -3191,7 +4215,7 @@ namespace eval punk { } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { - error "pipesyntax punk::% unable to interpret pipeline '$args'" + error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] } } else { if {$is_script} { @@ -3248,7 +4272,7 @@ namespace eval punk { set cmdlist [list $assign {*}$arglist] #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { - error "pipesyntax punk::% unable to interpret pipeline '$args'" + error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] } } else { set cmdlist $args @@ -3256,35 +4280,27 @@ namespace eval punk { #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] } - if {[catch {uplevel 1 $cmdlist} result]} { + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + #puts stderr "pipematch erroptions:$erroptions" #debug.punk.pipe {pipematch error $result} 4 - if {[string match "binding mismatch*" $result]} { + set ecode [dict get $erroptions -errorcode] + if {[lrange $ecode 0 1] eq "binding mismatch"} { #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch #return [dict create error [dict create mismatch $result]] #puts stderr "pipematch converting error to {error {mismatch }}" return [list error [list mismatch $result]] } - if {[string match "pipesyntax*" $result]} { - error $result + if {[lindex $ecode 0] eq "pipesyntax"} { + #error $result + return -options $erroptions $result + } + if {[lindex $ecode 0] eq "casematch"} { + return $result } #return [dict create error [dict create reason $result]] return [list error [list reason $result]] } else { - # - if {[catch {lrange $result 0 1} first2wordsorless]} { - #if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' - puts ">>>>>>>>>>>>>>>>>>>>>> $result" - return [list ok [list result $result]] - } else { - if {$first2wordsorless eq {binding mismatch}} { - puts stderr "pipematch got structured return 'binding mismatch' WRAPPING OK ANYWAY " - return [list ok [list result $result]] - #return $result - } else { - #puts >>2>[rep $result] - return [list ok [list result $result]] - } - } + return [list ok [list result $result]] #debug.punk.pipe {pipematch result $result } 4 #return [dict create ok [dict create result $result]] } @@ -3293,7 +4309,7 @@ namespace eval punk { proc pipenomatchvar {varname args} { if {[string first = $varname] >=0} { #first word "pipesyntax" is looked for by pipecase - error "pipesyntax pipenomatch expects a simple varname as first argument" + error "pipesyntax pipenomatch expects a simple varname as first argument" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] } #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 @@ -3321,23 +4337,24 @@ namespace eval punk { } upvar 1 $varname nomatchvar - if {[catch {uplevel 1 $cmdlist} result]} { + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + set ecode [dict get $erroptions -errorcode] debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a+]} 3 - if {[string match "pipesyntax*" $result]} { + if {[lindex $ecode 0] eq "pipesyntax"} { set errordict [dict create error [dict create pipesyntax $result]] set nomatchvar $errordict - error $result + return -options $erroptions $result } - if {[string match "binding mismatch*" $result]} { + if {[lrange $ecode 0 1] eq "binding mismatch"} { #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch set errordict [dict create error [dict create mismatch $result]] set nomatchvar $errordict - error $result + return -options $erroptions $result } set errordict [dict create error [dict create reason $result]] set nomatchvar $errordict #re-raise the error for pipeswitch to deal with - error $result + return -options $erroptions $result } else { debug.punk.pipe {pipematchnomatch result $result } 4 set nomatchvar "" @@ -3355,8 +4372,9 @@ namespace eval punk { if {$assign eq ".="} { set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] } elseif {$assign eq "="} { - set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] - } elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + set cmdlist [list = {*}$arglist] + } elseif {![punk::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} #set re_equals {^([^ \t\r\n=\{]*)=$} if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { @@ -3365,7 +4383,7 @@ namespace eval punk { set cmdlist [list $assign {*}$arglist] #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { - error "pipesyntax punk::% unable to interpret pipeline '$args'" + error "pipesyntax pipecase unable to interpret pipeline '$args'" } #todo - account for insertion-specs e.g x=* x.=/0* } else { @@ -3374,19 +4392,28 @@ namespace eval punk { } - if {[catch {uplevel 1 [list if 1 $cmdlist]} result]} { - #puts stderr "====>>> $result" - if {[string match "pipesyntax*" $result]} { - error $result + if {[catch {uplevel 1 [list if 1 $cmdlist]} result erroptions]} { + #puts stderr "====>>> result: $result erroptions" + set ecode [dict get $erroptions -errorcode] + if {[lindex $ecode 0] eq "pipesyntax"} { + #error $result + return -options $erroptions $result + } + if {[lindex $ecode 0] eq "casenomatch"} { + return -options $erroptions $result } - if {[string match "binding mismatch*" $result]} { + if {[lrange $ecode 0 1] eq "binding mismatch"} { #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch - return [dict create error [dict create mismatch $result]] - #return [dict create error [dict create reason $result]] + #return [dict create error [dict create mismatch $result]] + # + #NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) + return [dict create casemismatch $result] } - #we can't always treat $result as a list - may be malformed + #we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode + #todo - use errorCode instead if {[catch {lindex $result 0} word1]} { - tailcall error $result + #tailcall error $result + return -options $erroptions $result } else { if {$word1 in [list "switcherror" "funerror"]} { error $result "pipecase [lsearch -all -inline $args "*="]" @@ -3402,11 +4429,12 @@ namespace eval punk { } else { #normal tcl error #return [dict create error [dict create reason $result]] - tailcall error $result + tailcall error $result "pipecase $args" [list caseerror] + } } } else { - tailcall return [dict create ok [dict create result $result]] + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] } } @@ -3422,11 +4450,11 @@ namespace eval punk { #set upargs $nextargs upvar switchargs switchargs set switchargs $args - uplevel 1 [list if 1 $pipescript] + uplevel 1 [::list ::if 1 $pipescript] } #static-closure version - because we shouldn't be writing back to calling context vars directly #Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! - #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that isn't an important usecase) + #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) proc pipeswitchc {pipescript args} { set binding {} if {[info level] == 1} { @@ -3445,7 +4473,7 @@ namespace eval punk { } } lappend binding [list switchargs $args] - apply [list $binding $pipescript [uplevel 1 namespace current]] + apply [list $binding $pipescript [uplevel 1 {::namespace current}]] } proc pipedata {data args} { @@ -3493,6 +4521,9 @@ namespace eval punk { append e { $data} set r [apply [list {data} $e] $r] } + } elseif {[llength $e] == 0} { + #do nothing - pass data through + #leave r as is. } else { set r [apply [list {data} $e] $r] } @@ -3969,76 +5000,600 @@ namespace eval punk { } #------------------------------------------------------------------- - namespace export help aliases alias cdwin cdwindir dirfiles dirfiles_dict exitcode winpath windir % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines is_list_all_in_list is_list_all_ni_list val treemore + namespace export help aliases alias nsjoin nsprefix cdwin cdwindir dirfiles dirfiles_dict exitcode winpath windir % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines is_list_all_in_list is_list_all_ni_list val treemore namespace ensemble create + proc hasglobs {str} { + expr {[string first * $str]>=0 || [string first ? $str]>=0} + } + + + #todo - package up as navns + proc corp {path} { + #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp + #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) + if {[info exists ::auto_index($path)]} { + set body "# $::auto_index($path)\n" + } else { + set body "" + } + + if {[string match ::* $path]} { + set targetns [nsprefix $path] + set name [nstail $path] + } else { + set thispath [uplevel 1 [list nsthis $path]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] + #set upns [uplevel 1 [list namespace current]] + } + #puts stderr "corp upns:$upns" + + #set name [string trim $name :] + #set origin [namespace origin ${upns}::$name] + set origin [punk::nseval $targetns [list ::namespace origin $name]] + + #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! + if {$origin ni [info procs $origin]} { + + #It seems an interp alias of "::x"" behaves the same as "x" + #But we can't create both at the same time - and they have to be queried by the exact name. + #So we query for alias with and without leading :: + set alias_qualified [interp alias {} [string trim $origin :]] + set alias_unqualified [interp alias {} $origin] + if {[string length $alias_qualified] && [string length $alias_unqualified]} { + #our assumptions are wrong.. change in tcl version? + puts stderr "corp: Found alias for unqualified name:'[string trim $origin :]' and qualified name: '$origin' - unexpected (assumed impossible as at Tcl 8.6)" + if {$alias_qualified ne $alias_unqalified} { + + } else { + set alias $alias_unqualified + } + } else { + set alias ${alias_qualified}${alias_unqualified} ;#concatenate - as at least one should be empty + } + + if {[string length $alias]} { + #todo - consider following alias-chain to ultimate proc? + #it can always be manually done with: + #.= corp $name |/1> corp |/1> corp .. + #depending on number of aliases in the chain + return [list alias {*}$alias] + } + } + if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { + append body "# namespace origin $origin" + } + + append body [info body $origin] + set argl {} + foreach a [info args $origin] { + if {[info default $origin $a def]} { + lappend a $def + } + lappend argl $a + } + list proc [nsjoin ${targetns} $name] $argl $body + } + + proc nsjoin {prefix name} { + if {[string match ::* $name]} { + if {[string length $prefix]} { + error "nsjoin: won't join non-empty prefix to absolute namespace path '$name'" + } + return $name + } + if {$prefix eq "::"} { + return ::$name + } + return ${prefix}::$name + } + proc nsjoinall {prefix args} { + #if {![llength $args]} { + # error "usage: nsjoinall prefix relativens \[relativens ...\]" + #} + set segments [list $prefix] + foreach sub $args { + if {[string match ::* $sub]} { + if {[string length [concat {*}$segments]]} { + error "nsjoin: won't join non-empty namespace prefix to absolute namespace path '$sub'" + } + } + lappend segments $sub + } + set nonempty_segments [list] + foreach s $segments { + if {[string length $s]} { + lappend nonempty_segments $s + } + } + if {$prefix eq "::"} { + return ::[join [lrange $nonempty_segments 1 end] ::] + } + return [join $nonempty_segments ::] + } + proc nsprefix {{name ""}} { + set rawprefix [string range $name 0 end-[string length [punk::nstail $name]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + return [string trimright $rawprefix :] + } + } + + #namespace tail which handles :::cmd ::x:::y ::x:::/y etc + #todo - raise error for unexpected sequences such as :::: or more than 2 colons together. + proc nstail {nspath args} { + set mapped [string map [list :: \u0FFF] $nspath] + set parts [split $mapped \u0FFF] + + set defaults [list -strict 0] + set opts [dict merge $defaults $args] + set strict [dict get $opts -strict] + + if {$strict} { + foreach p $parts { + if {[string match :* $p]} { + error "nstail unpaired colon ':' in $nspath" + } + } + } + + #e.g ::x::y:::z should return ":z" + return [lindex $parts end] + } + + #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) + #'supports' weird namespaces /commands such as :x :::x ::x:::y + #Can be used to either suppor use of such namespaces/commands - or as part of validation to disallow them + #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #This is because Tcl's 'namespace eval "" ""' reports 'only global namespace can have empty name' + # + proc nsparts {nspath} { + set mapped [string map [list :: \u0FFF] $nspath] + set parts [split $mapped \u0FFF] + if {[lindex $parts end] eq ""} { + + } + return $parts + } + + #review ??? + proc ns_relative_to_location {name} { + if {[string match ::* $name]} { + error "ns_relative_to_location accepts a relative namespace name only ie one without leading ::" + } + + } + proc ns_absolute_to_location {name} { + + } + + + interp alias {} nsjoin {} punk::nsjoin + interp alias {} nsprefix {} punk::nsprefix + interp alias {} nstail {} punk::nstail + + #tcl 8.x has creative writing var weirdness.. tcl 9 is likely to differ + proc nsvars {{nsglob "*"}} { + set ns_absolute [uplevel 1 [list punk::nspath_here_absolute $nsglob]] + #set commandns [uplevel 1 [list namespace current]] + + set searchns [nsprefix $ns_absolute] ;#the ns within which we want to searchns + set searchall [nsjoin $searchns *] ;#will correctly form ::* or ::childns::* + + set rawresult [info vars $searchall] ;#will not find vars in ::x:::y etc. - seems to be impossible in tcl 8.x + set matched_fullpath [list] + foreach r $rawresult { + lappend matched_fullpath [nstail $r] + } + + set location [nsprefix $ns_absolute] + set tailmatch [nstail $ns_absolute] + set raw_matched_in_ns [punk::nseval $location [list ::info vars $tailmatch]] + #NOTE: tcl <9 will read vars from global namespace - so we are only checking the intersection here + #(this is due to info vars ::etc:::blah failing to handle additional colon) + set matched_in_ns [list] + set result [list] + foreach r $raw_matched_in_ns { + set m [nstail $r] + lappend matched_in_ns $m + if {$m in $matched_fullpath} { + lappend result $m + } + } + + + return [list_as_lines [lsort $result]] + #.= lsort $result |> list_as_lines + } + interp alias {} nsvars {} punk::nsvars + interp alias {} nsorigin {} apply {ns {namespace origin [uplevel 1 nsthis $ns]} ::} + + #todo - walk up each ns - testing for possibly weirdly named namespaces + proc nsexists {nspath} { + + } + + #create possibly nested namespace structure - but only if not already existant + proc n/new {args} { + variable ns_current + if {![llength $args]} { + error "usage: :/new \[ ...\]" + } + set a1 [lindex $args 0] + set is_absolute [string match ::* $a1] + if {$is_absolute} { + set nspath [nsjoinall {*}$args] + } else { + if {[string match :* $a1]} { + puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + } + set nspath [nsjoinall $ns_current {*}$args] + } + + set ns_exists [punk::nseval [punk::nsprefix $nspath] [list namespace exists [punk::nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #namespace eval [nsprefix $nspath] [list namespace eval [nstail $nspath] {}] + punk::nseval [nsprefix $nspath] [list ::namespace eval [nstail $nspath] {}] + n/ $nspath + } + + + #nn/ ::/ nsup/ - back up one namespace level + proc nsup/ {v args} { + variable ns_current + if {$ns_current eq "::"} { + puts stderr "Already at global namespace '::'" + } else { + set out "" + set nsq [nsprefix $ns_current] + if {$v eq "/"} { + set out [punk::get_nslist -match [nsjoin $nsq *] -types [list children]] + } else { + set out [punk::get_nslist -match [nsjoin $nsq *] -types [list all]] + } + #set out [punk::nslist [nsjoin $nsq *]] + set ns_current $nsq + append out "\n$ns_current" + return $out + } + } + + + + #experimental + #is there ever any difference to {namespace current}? + #interp alias {} nsthis {} .= .= namespace code {namespace current} |> .=* <0/#| + #interp alias {} nsthis {} namespace current + interp alias {} nsthis {} punk::nspath_here_absolute + proc nspath_here_absolute {{nspath ""}} { + set path_is_absolute [expr {[string match ::* $nspath]}] + if {$path_is_absolute} { + return $nspath + } + set ns_caller [uplevel 1 {namespace current}] + if {![string length $nspath]} { + return $ns_caller + } + return [punk::nsjoin $ns_caller $nspath] + } + + proc nspath_to_absolute {nspath base} { + set path_is_absolute [expr {[string match ::* $nspath]}] + if {$path_is_absolute} { + return $nspath + } + if {![string length $nspath]} { + return $base + } + return [punk::nsjoin $base $nspath] + } + + #cli command - impure - relies on caller/ns_current proc nslist_dict {{glob "*"}} { + set ns_absolute [uplevel 1 [list punk::nspath_here_absolute $glob]] + return [get_nslist_dict $ns_absolute] + } + proc nslist_dict1 {{glob "*"}} { variable ns_current ;#keep fully qualified ie :: or ::etc + set ns_caller [uplevel 1 {namespace current}] + puts "nslist_dict ns_caller: $ns_caller (ns_current: $ns_current)" + set glob_is_absolute [expr {[string match ::* $glob]}] - set nsquals [namespace qualifiers $glob] - if {[string length $nsquals]} { + set globquals [namespace qualifiers $glob] + if {[string length $globquals]} { if {$glob_is_absolute} { - set fqpath $nsquals + set fqpath $globquals } else { - set fqpath ${ns_current}::${nsquals} + set fqpath ${ns_caller}::${globquals} } } else { if {$glob_is_absolute} { set fqpath :: } else { - set fqpath $ns_current + set fqpath $ns_caller } } #puts stderr ">>fqpath $fqpath" - set nstail [namespace tail $glob] - if {[string first ? $nstail] >= 0 || [string first * $nstail] >=0} { + set globtail [nstail $glob] + if {[hasglobs $globtail]} { set location $fqpath - set glob $nstail + set glob $globtail } else { + if {$fqpath eq "::"} { - set location ::${nstail} + set location ::${globtail} } else { - if {[string length $nstail]} { - set location ${fqpath}::${nstail} + if {[string length $globtail]} { + set location ${fqpath}::${globtail} } else { set location ${fqpath} } } set glob * } + return [get_nslist_dict ${location}::$glob] + } + + #recursive nseval - for introspection of weird namespace trees + #approx 10x slower than normal namespace eval - but still only a few microseconds.. fine for repl introspection + proc nseval_script {location} { + set parts [nsparts $location] + if {[lindex $parts 0] eq ""} { + lset parts 0 :: + } + if {[lindex $parts end] eq ""} { + set parts [lrange $parts 0 end-1] + } + + set body "" + set i 0 + set tails [lrepeat [llength $parts] ""] + foreach ns $parts { + set cmdlist [list namespace eval $ns] + set t "" + if {$i > 0} { + append body " " + } + append body $cmdlist + if {$i == ([llength $parts] -1)} { + append body "