From c37bf21eb7030a337de80b5e7b3dfa264e18315c Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 5 Jun 2023 08:05:41 +1000 Subject: [PATCH] pipeline fixes and better pattern matching and assignment --- src/modules/punk-0.1.tm | 1055 +++++++++++++++++++++++++-------------- 1 file changed, 682 insertions(+), 373 deletions(-) diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index b34d5350..85cbfa5d 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -43,7 +43,9 @@ namespace eval punk::config { variable loaded variable startup ;#include env overrides variable running - + + + variable vars set vars [list \ apps \ scriptlib \ @@ -84,6 +86,7 @@ namespace eval punk::config { #env vars override the configuration #todo - define which configvars are settable in env + variable known_punk_env_vars set known_punk_env_vars [list \ PUNK_APPS \ PUNK_SCRIPTLIB \ @@ -97,6 +100,7 @@ namespace eval punk::config { ] #override with env vars if set + variable evar foreach evar $known_punk_env_vars { if {[info exists ::env($evar)]} { set f [set ::env($evar)] @@ -107,12 +111,16 @@ namespace eval punk::config { } } } + unset -nocomplain evar + unset -nocomplain vars + unset -nocomplain known_punk_env_vars set running [dict create] set running [dict merge $running $startup] } namespace eval punk { + interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system package require pattern package require punkapp package require funcl @@ -189,7 +197,7 @@ namespace eval punk { } #debatable whether boolean_almost_equal is likely to be surprising or helpful. #values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically - #perhaps a fuzzy-boolean is a step too far for a default. use an even more complex classifier? (^&~) ? + #perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. use an even more complex classifier? (^&~) ? proc boolean_almost_equal {a b} { if {[string is double -strict $a]} { if {[float_almost_equal $a 0]} { @@ -315,8 +323,10 @@ namespace eval punk { proc _split_var_key_at_unbracketed_comma {varspecs} { set varlist [list] set var_terminals [list "@" "/" "#"] - set protect_terminals [list "^"] ;# e.g sequence ^# #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 + #ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' set in_brackets 0 #set varspecs [string trimleft $varspecs ,] set token "" @@ -785,7 +795,7 @@ namespace eval punk { #} incr i_keyindex } - + #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 @@ -807,17 +817,17 @@ namespace eval punk { } set returndict [dict create ismatch 0 result "" setvars {} unsetvars {}] - set defaults [list -unset 0 -levelup 2 ] + set defaults [list -unset 0 -levelup 2 -mismatchinfo 1] 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 varkeylist [_split_var_key_at_unbracketed_comma $multivar] - #puts stdout "\n varkeylist: $varkeylist\n" + set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] #first classify into var_returntype of either "pipeline" or "segment" #segment returntype is indicated by leading % @@ -825,7 +835,7 @@ namespace eval punk { #mutually exclusive - atom/pin #set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin - #set var_class [lmap var $varkeylist {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] + #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 ^ @@ -841,75 +851,90 @@ namespace eval punk { 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 expected_values [list] #set expected_values [lmap v $var_names {list $v "-" ""}] #e.g {a = abc} {b unset ""} - foreach v_key $varkeylist { + 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 - } elseif {[string is integer -strict $v]} { - #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 - } elseif {[string is double -strict $v]} { - #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 } else { - set firstclassifier [string index $v 0] - if {$firstclassifier eq "'"} { - lappend var_class [list $v_key 1] - set vname [string range $v 1 end] - lappend varspecs_trimmed [list $vname $key] - } elseif {$firstclassifier 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] - } - #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 {$firstclassifier eq "&"} { - lappend var_class [list $v_key 3] - set vname [string range $v 1 end] - lappend varspecs_trimmed [list $vname $key] + 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] + } + #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 "&"} { + 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 { - lappend var_class [list $v_key 6] ;#var - lappend varspecs_trimmed $v_key + 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 + } 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 + } + } else { + lappend var_class [list $v_key 6] ;#var + lappend varspecs_trimmed $v_key + } } } + } lappend var_names $vname - lappend var_actions [list $vname "" ""] - lappend expected_values [list spec $vname info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default + 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 "\n var_class: $var_class\n" @@ -951,7 +976,6 @@ namespace eval punk { debug.punk.pipe.var {initial map expected_values: $expected_values} 5 - set returnval "" set i 0 #assert i incremented at each continue and at each end of loop - at end i == list length + 1 @@ -973,6 +997,7 @@ 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 @@ -997,10 +1022,10 @@ namespace eval punk { set vkey [string trimleft $vkey /] - #puts stderr ">>>>>>>>>>>>>>>> $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 @ @@ -1012,6 +1037,9 @@ namespace eval punk { 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] @@ -1164,7 +1192,7 @@ namespace eval punk { if {$unset} { #if {[string length $v]} { - # catch {uplevel $lvlup [list unset $v]} + # uplevel $lvlup [list unset -nocomplain $v] #} lset var_actions $i 1 ?unset set assigned "" @@ -1199,11 +1227,13 @@ namespace eval punk { set returnval [lindex $assigned_values 0] + #puts stdout "----> > rep returnval: [rep $returnval]" #assert all var_actions were set with leading question mark #perform assignments only if matched ok debug.punk.pipe.var {VAR_CLASS: $var_class} 5 debug.punk.pipe.var {VARACTIONS: $var_actions} 5 + debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 #0 - novar #1 - atom ' @@ -1213,7 +1243,7 @@ namespace eval punk { #5 - double #6 - var #7 - glob (no classifier and contains * or ?) - if 1 { + if 0 { debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 @@ -1224,12 +1254,24 @@ namespace eval punk { } set match_state [lrepeat [llength $var_names] ?] - + unset -nocomplain v + unset -nocomplain nm set mismatched [list] set i 0 #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) foreach va $var_actions { - lassign $va nm act val + lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" + set varname [lindex $var_names $i] + + if {[string match "?mismatch*" $act]} { + #already determined a mismatch - e.g list or dict key not present + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val] + break + } + + + set class_key [lindex $var_class $i 1] set isatom [expr {$class_key == 1}] set ispin [expr {2 in $class_key}] @@ -1238,45 +1280,77 @@ namespace eval punk { set isdouble [expr {$class_key == 5}] set isvar [expr {$class_key == 6}] set isglob [expr {7 in $class_key}] - set isnumeric [expr {8 in $class_key}] ;#force numeric comparison - + 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? - + + + + if {$isatom} { + #puts stdout "==>isatom $lhsspec" + set lhs [string range $lhsspec 1 end] + if {$act eq "?set"} { + lset var_actions $i 1 matchatom-set + if {$lhs eq $val} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] + incr i + continue + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] + break + } + } elseif {$act eq "?unset"} { + #doesn't make sense for an atom ? - should fail match + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "unable-to-unset-atom" lhs $lhs rhs $val] + break + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info unkown-action-$act lhs $lhs rhs $val] + break + } + } + + + + # - should set expected_values in each branch where match_state is not set to 1 # - setting expected_values when match_state is set to 0 is ok except for performance - if {[string match "?mismatch*" $act]} { - #already determined a mismatch - e.g list or dict key not present - lset match_state $i 0 - lset expected_values $i [list spec $nm info mismatch lhs ? rhs $val] - break - } #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) if {$ispin} { - #puts stdout "==>ispin $nm" + #puts stdout "==>ispin $lhsspec" if {$act in [list "?set" "?matchvar-set"]} { lset var_actions $i 1 matchvar-set #attempt to read - upvar $lvlup $nm the_var - #if {![catch {uplevel $lvlup [list set $nm]} existingval]} {} + upvar $lvlup $varname the_var + #if {![catch {uplevel $lvlup [list set $varname]} existingval]} {} if {![catch {set the_var} existingval]} { if {$isbool} { #isbool due to 2nd classifier i.e ^& - lset expected_values $i [list spec $nm info match-lhs-bool lhs $existingval rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] } elseif {$isglob} { #isglob due to 2nd classifier ^* - lset expected_values $i [list spec $nm info match-lhs-glob lhs $existingval rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] } elseif {$isnumeric} { - - if {[string is integer -strict $existingval]} { + #flagged as numeric by user using ^# classifiers + set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + if {[string is integer -strict $testexistingval]} { set isint 1 - lset expected_values $i [list spec $nm info match-lhs-int lhs $existingval rhs $val] - } elseif {[string is double -strict $existingval]} { + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] + } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { + #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) set isdouble 1 - lset expected_values $i [list spec $nm info match-lhs-double lhs $existingval rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] + } else { + #user's variable doesn't seem to have a numeric value + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] + break } } else { @@ -1284,83 +1358,74 @@ namespace eval punk { lset match_state $i [expr {$existingval eq $val}] if {![lindex $match_state $i]} { lset match_state $i 0 - lset expected_values $i [list spec $nm info match lhs $existingval rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] break } } } else { - #puts stdout "var ^$nm result:$result vs val:$val" + #puts stdout "pinned var $varname result:$result vs val:$val" #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace lset match_state $i 0 - lset expected_values $i [list spec $nm info failread lhs ? rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] break } } if {$act in [list "?unset" "?matchvar-unset"]} { lset var_actions $i 1 matchvar-unset - upvar $lvlup $nm the_var + upvar $lvlup $varname the_var if {![info exists the_var]} { lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-already-unset lhs "" rhs ""] } else { #attempt to unset a pinned var that has a value - non-match. ^x= will only match an unset variable x lset match_state $i 0 - lset expected_values $i [list spec $nm info attempt-to-unset-pinned-var-with-value lhs [set the_var] rhs ""] + lset expected_values $i [list var $varname spec $lhsspec info attempt-to-unset-pinned-var-with-value lhs [set the_var] rhs ""] break } } } - if {$isatom} { - #puts stdout "==>isatom $nm" - if {$act in [list "?set"]} { - lset var_actions $i 1 matchatom-set - if {$nm eq $val} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list spec $nm info match lhs [string range $nm 1 end] rhs $val] - break - } - } elseif {$act eq "?unset"} { - #doesn't make sense for an atom ? - should fail match - lset match_state $i 0 - lset expected_values $i [list spec $nm info match lhs [string range $nm 1 end] rhs $val] - break - } else { - lset match_state $i 0 - lset expected_values $i [list spec $nm info unkown lhs [string range $nm 1 end] rhs $val] - break - } - } elseif {$isint} { - #todo - decide on what diagnosis info to put in expected_values -- or tidy up and shrink duplicate branches. - #expected_values $i [list spec $nm info match-lhs-int lhs $existingval rhs $val] + + if {$isint} { + #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. + #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] if {$act eq "?set"} { if {$ispin} { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] } else { - set lhs $nm ;#literal integer in the pattern + set lhs $lhsspec ;#literal integer in the pattern } - if {[string is integer -strict $val]} { - if {$lhs == $val} { + if {[string index $lhs 0] eq "."} { + set testlhs $lhs + } else { + set testlhs [join [scan $lhs %lld%s] ""] + } + if {[string index $val 0] eq "."} { + set testval $val + } else { + 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 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info "expr-mismatch-int-int" lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] break } - } elseif {[string is double -strict $val]} { + } elseif {[string is double -strict $testval]} { #dragons. (and shimmering) if {[string first "e" $val] != -1} { #scientific notation - let expr compare - if {$lhs == $val} { + if {$testlhs == $testval} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info "expr-mismatch-int-sci" lhs $lhs rhs $val] + 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 -]] } { @@ -1373,30 +1438,29 @@ namespace eval punk { #string comparison can presumably always be used as an alternative. # #let expr compare - if {$lhs == $val} { + if {$testlhs == $testval} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] break } } else { - #review! if we're using float_almost_equal at all.. should we use it always? - if {[punk::float_almost_equal $lhs $val]} { + if {[punk::float_almost_equal $testlhs $testval]} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] break } } } else { - #unknown - todo warn? - if {$lhs == $val} { + #e.g rhs not a number.. + if {$testlhs == $testval} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info "expr-mismatch-unknown" lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] break } } @@ -1408,33 +1472,39 @@ namespace eval punk { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] } else { - set lhs $nm ;#literal integer in the pattern + set lhs $lhsspec ;#literal integer in the pattern } - - if {[string first "e" $lhs] >= 0 || [string first "e" $val] >= 0} { - if {$lhs == $val} { + if {[string index $val 0] eq "."} { + set testval $val ;#not something with some number of leading zeros + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + } + #expr handles leading 08.1 0009.1 etc without triggering octal + #so we don't need to scan lhs + if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { + if {$lhs == $testval} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info expr-mismatch-sci lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info expr-mismatch-sci lhs $lhs rhs $val] break } } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { #both look like big whole numbers.. let expr compare using it's bignum capability - if {$lhs == $val} { + if {$lhs == $testval} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info expr-mismatch-pure-digits lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info expr-mismatch-pure-digits lhs $lhs rhs $val] break } } else { #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch - if {[punk::float_almost_equal $lhs $val]} { + if {[punk::float_almost_equal $lhs $testval]} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info float_almost_equal-mismatch lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info float_almost_equal-mismatch lhs $lhs rhs $val] break } } @@ -1446,7 +1516,7 @@ namespace eval punk { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] } else { - set lhs $nm ;#literal boolean (&yes,&false,&1,&0 etc) in the pattern + set lhs [string range $lhsspec 1 end] ;#literal boolean (&yes,&false,&1,&0 etc) in the pattern - strip off & classifier prefix } if {![catch {punk::boolean_almost_equal $lhs $val} ismatch]} { @@ -1454,13 +1524,13 @@ namespace eval punk { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info boolean-mismatch lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info boolean-mismatch lhs $lhs rhs $val] break } } else { #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean lset match_state $i 0 - lset expected_values $i [list spec $nm info boolean-badvalue lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info boolean-badvalue lhs $lhs rhs $val] break } @@ -1472,13 +1542,13 @@ namespace eval punk { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] } else { - set lhs $nm ;#literal glob in the pattern + set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix } if {[string match $lhs $val]} { lset match_state $i 1 } else { lset match_state $i 0 - lset expected_values $i [list spec $nm info "glob-mismatch" lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info "glob-mismatch" lhs $lhs rhs $val] break } } @@ -1487,7 +1557,7 @@ namespace eval punk { #handled above.. leave case in place so we don't run else for pins } else { - #puts stdout "==> $nm" + #puts stdout "==> $lhsspec" #unpinned non-atoms will be set/unset - always considered a match lset match_state $i 1 lset var_actions $i 1 [string range $act 1 end] @@ -1510,34 +1580,26 @@ namespace eval punk { debug.punk.pipe.var {EXPECTED : $expected_values} 4 #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join - #catch {unset v} if {$match_count == $match_count_needed} { #do assignments set i 0 foreach va $var_actions { - lassign $va nm act val - set isvar [expr {[lindex $var_class $i 1] == 6}] - if {$isvar} { - if {[lindex $var_actions $i 1] eq "set"} { - if {[string length $nm]} { - upvar $lvlup $nm the_var - set the_var $val - #uplevel $lvlup [list set $nm $val] - } - } - if {[lindex $var_actions $i 1] eq "unset"} { - if {[string length $nm]} { - upvar $lvlup $nm the_var - catch {unset the_var} - #catch {uplevel $lvlup [list unset $nm]} - } - } + #set isvar [expr {[lindex $var_class $i 1] == 6}] + if {([lindex $var_class $i 1] == 6) && ([string length [set varname [lindex $var_names $i]]])} { + #isvar + lassign $va lhsspec act val + upvar $lvlup $varname the_var + if {[lindex $var_actions $i 1] eq "set"} { + set the_var $val + } elseif {[lindex $var_actions $i 1] eq "unset"} { + unset -nocomplain the_var + } } incr i } } else { #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message - #e.g for within pipeswitch block where mismatches are expected and the reasons are unimportant + #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly set vidx 0 set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] set var_display_names [list] @@ -1564,38 +1626,47 @@ namespace eval punk { #6 - var #7 - glob (no classifier and contains * or ?) foreach mismatchinfo $mismatches { - lassign $mismatchinfo status nm + lassign $mismatchinfo status varname if {$status eq "mismatch"} { - # nm can be empty string + # varname can be empty string set varclass [lindex $var_class $i 1] set val [lindex $var_actions $i 2] set e [dict get [lindex $expected_values $i] lhs] + set type "" + if {2 in $varclass} { + append type "pinned " + } + if {$varclass == 1} { set type "atom" } elseif {$varclass == 2} { set type "pinned var" - } elseif {$varclass == 4} { - set type "int" - } elseif {$varclass == 5} { - set type "double" - } else { + } elseif {3 in $varclass} { + append type "boolean" + } elseif {4 in $varclass} { + append type "int" + } elseif {5 in $varclass} { + append type "double" + } elseif {$varclass == 6} { set type "var" - #set e "*" ;# non-atoms and non-pins should always match.. todo - review attempt to set as var instead of array? + } elseif {7 in $varclass} { + append type "glob" + } elseif {8 in $varclass} { + append type "numeric" + } + if {$type eq ""} { + set type "" } - set lhs_tag "" - set mismatch_reason "" - if {[dict get [lindex $expected_values $i] info] ne "match"} { - set lhs_tag "- [dict get [lindex $expected_values $i] info]" - set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range - set tag "?mismatch-" - if {[string match $tag* $mmaction]} { - set mismatch_reason [string range $mmaction [string length $tag] end] - } else { - set mismatch_reason $mmaction - } + set lhs_tag "- [dict get [lindex $expected_values $i] info]" + set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range + set tag "?mismatch-" + if {[string match $tag* $mmaction]} { + set mismatch_reason [string range $mmaction [string length $tag] end] + } else { + set mismatch_reason $mmaction } - append msg " $type: '$nm' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" + append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" } incr i } @@ -1606,18 +1677,26 @@ namespace eval punk { return $returndict } - if {![llength $varkeylist]} { + if {![llength $valsource_key_list]} { dict set returndict result $data } else { - #punk::assert {$i == [llength $varkeylist]} + #punk::assert {$i == [llength $valsource_key_list]} dict set returndict result $returnval } return $returndict } - - proc _handle_bind_result {d} { + ######################################################## + # serious 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. + # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! + # A proper solution may involve a callback? tailcall some_mismatch_func? + # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ?? + # make sure there is good test coverage before experimenting with this + proc _handle_bind_result {d} { #set match_caller [info level 2] #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 if {![dict exists $d result]} { @@ -1627,13 +1706,39 @@ namespace eval punk { return [dict get $d result] } } + # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + proc _handle_bind_result_experimental1 {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + tailcall return [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + ######################################################## + + #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. + #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' + #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. + #proc listset1 {listvarname args} { + # tailcall set $listvarname $args + #} + #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} + #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} + proc pipeset {pipevarname args} { + upvar $pipevarname the_pipe + set the_pipe $args + } + #same as used in unknown func for initial launch #variable re_assign {^([^\r\n=\{]*)=(.*)} variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} #match_assign is tailcalled from unknown - uplevel 1 gets to caller level - proc match_assign {multivar e1 fulltail} { - debug.punk.pipe {match_assign '$multivar' '$e1' '$fulltail'} 4 + proc match_assign {multivar equalsrhs fulltail} { + #equalsrhs is set if ther is something *directly* after the = + debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 #can match an integer on lhs with a value # #if {[string is integer -strict $multivar]} { @@ -1642,22 +1747,42 @@ namespace eval punk { #} - #attempting to allow x=y to begin a pipeline e.g x=y |> string tolower - #will stop us from easily assigning an entire pipeline string to x using the 'equals-runon' syntax x=.=something etc |> blah - #The tradeoff + # allow x=y to begin a pipeline e.g x=y |> string tolower ? + #assigning an entire pipeline string to x using the 'equals-runon' syntax requires an exception. Just "%" in equalsrhs position to be handled differently. x=% .=something etc |> blah + #Review - is this breaking of consistency really worthwhile? we could always require standard tcl assignment for pipelines - which are a list anyway + # more explicit and consistent would be a command that takes args: + # pipeset var % .= etc ... + # lappend var }] set firstpipe_posn [lsearch $fulltail "|*>"] - - if {$firstpipe_posn >=0} { - set firstpipe [lindex $fulltail $firstpipe_posn] - set tail [lrange $fulltail 0 $firstpipe_posn-1] - set nextassignment [lindex $fulltail $firstpipe_posn+1] - set nexttail [lrange $fulltail $firstpipe_posn+1 end] + set argpipe_posn [lsearch $fulltail "<*|"] + if {$firstpipe_posn == -1} { + set endsegment_posn $argpipe_posn + } elseif {$argpipe_posn == -1} { + set endsegment_posn $firstpipe_posn } else { - set tail $fulltail + set endsegment_posn [expr {min($firstpipe_posn, $argpipe_posn)}] + } + set pipe_args [list] + if {$endsegment_posn >=0} { + #defer to pipeline command for all pipelines. + tailcall punk::pipeline = $multivar $equalsrhs {*}$fulltail + + + set segmenttail [lrange $fulltail 0 $endsegment_posn-1] + set firstpipe [lindex $fulltail $endsegment_posn] + set nextassignment [lindex $fulltail $endsegment_posn+1] + set nexttail [lrange $fulltail $endsegment_posn+1 end] + if {$argpipe_posn >= 0} { + set pipe_args [lrange $fulltail $argpipe_posn+1 end] + } + } else { + set segmenttail $fulltail set nextassignment [list] set nexttail [list] } @@ -1665,7 +1790,8 @@ namespace eval punk { #puts stderr "tail-end: [lindex $fulltail end]" } else { set firstpipe_posn -1 - set tail [list] + set argpipe_posn -1 + set segmenttail [list] set nextassignment [list] set nexttail [list] } @@ -1673,17 +1799,19 @@ namespace eval punk { set is_listbuilder 0 - if {![string length $e1]} { + if {![string length $equalsrhs]} { #space after = - if {[llength $tail] == 1} { - set val [lindex $tail 0] - set d [_multi_bind_result $multivar $val] - set r [_handle_bind_result $d] - set returnval $r - } elseif {[llength $tail] == 0} { - set d [_multi_bind_result $multivar "" -unset 1] ;#final arg 1 to unset variables - set r [_handle_bind_result $d] ;# we can get a mismatch on unsetting a pinned var - so we need _handle_bind_result to give a chance to raise an error etc. - set returnval "" + if {[llength $segmenttail] == 0} { + + + #no longer do unset in pattern-matching ? + #set d [_multi_bind_result $multivar [purelist] -unset 1] ;#final arg 1 to unset variables + #_handle_bind_result $d ;# we can get a mismatch on unsetting a pinned var - so we need _handle_bind_result to give a chance to raise an error etc. + #set returnval "" + } elseif {[llength $segmenttail] == 1} { + #set val [lindex $segmenttail 0] + set d [_multi_bind_result $multivar [lindex [list [lindex $segmenttail 0] [unset segmenttail]] 0]] + set returnval [_handle_bind_result $d] } else { #keyword pipesyntax at beginning of error message set msg "pipesyntax\n" @@ -1698,35 +1826,33 @@ namespace eval punk { append msg "so the interpreter or commandline will consume following lines until a closing quote is found\n" error $msg } - } elseif {([llength $tail] == 0) && ($firstpipe_posn < 0)} { + } elseif {([llength $segmenttail] == 0) && ($firstpipe_posn == -1)} { #simple value assignment - even if it looks like an expression #ie x=4+1 assigns "4+1" as a string #whereas x=4 + 1 assigns 5 #set commaparts [split $var ,] - set d [_multi_bind_result $multivar $e1] - set r [_handle_bind_result $d] - set returnval $r + set d [_multi_bind_result $multivar [purelist $equalsrhs]] + set returnval [_handle_bind_result $d] } else { set is_listbuilder 1 #no space concatenation - good for command aliases debug.punk.pipe "assigning fulltail [llength $fulltail]" 6 - #e1 is not a list - may even be a single char such as double quote. - #set result [concat $e1 $fulltail] ;#concat produces a string rep - and strips escaped whitespace e.g \t or\n from e1 and trailing args. + #equalsrhs is not a list - may even be a single char such as double quote. + #set result [concat $equalsrhs $fulltail] ;#concat produces a string rep - and strips escaped whitespace e.g \t or\n from equalsrhs and trailing args. #set result [list] - #lappend result $e1 + #lappend result $equalsrhs #foreach a $fulltail { # lappend result $a #} #set result [list] - #lappend result $e1 {*}$fulltail + #lappend result $equalsrhs {*}$fulltail - set result [list $e1 {*}$fulltail] + set result [list $equalsrhs {*}$fulltail] set d [_multi_bind_result $multivar $result] - set r [_handle_bind_result $d] - set returnval $r + set returnval [_handle_bind_result $d] } #return $returnval @@ -1734,14 +1860,13 @@ namespace eval punk { if {![llength $nexttail] || $is_listbuilder} { return $returnval } else { - #set exectail [concat [list val $returnval] $firstpipe $nexttail] set exectail [list val $returnval $firstpipe {*}$nexttail] - #uplevel 1 [list punk::match_exec "" "" {*}$exectail] - tailcall punk::match_exec "" "" {*}$exectail + puts stderr $exectail + tailcall punk::pipeline .= "" "" {*}$exectail } + } - } proc _is_math_func_prefix {e1} { #also catch starting brackets.. e.g "(min(4,$x) " if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { @@ -1874,15 +1999,13 @@ namespace eval punk { } } - proc match_exec {initial_returnvarspec e1 args} { + proc pipeline {segment_op initial_returnvarspec e1 args} { set fulltail $args unset args - #debug.punk.pipe {call match_exec: '$initial_returnvarspec' '$e1' '$fulltail'} 9 + debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$e1' '$fulltail'} 4 #debug.punk.pipe.rep {[rep_listname fulltail]} 6 - #temp - set ::_pipescript "" #--------------------------------------------------------------------- @@ -1912,26 +2035,33 @@ namespace eval punk { error $msg } + #temp + set ::_pipescript "" + + #maintenance: punk::re_dot_assign - set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} - set re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #set re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} if {([string first = $next1] >= 0) && (![arg_is_script_shaped $next1]) } { - - if {[regexp $re_dot_assign $next1 _ nextreturnvarspec nextrhs]} { + #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::match_exec $nextreturnvarspec $nextrhs {*}$nexttail]] + set results [uplevel 1 [list ::punk::pipeline .= $nextreturnvarspec $nextrhs {*}$nexttail]] + #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 #debug.punk.pipe {>>> results: $results} 1 - set d [_multi_bind_result $initial_returnvarspec $results] - return [_handle_bind_result $d] + return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] } - if {[regexp $re_assign $next1 _ nextreturnvarspec nextrhs]} { + #puts "======> recurse asssign based on next1:$next1 " + #set re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} + if {[regexp {^[\{]{0,1}([^ \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::match_assign $nextreturnvarspec $nextrhs $nexttail]] + set results [uplevel 1 [list ::punk::pipeline = $nextreturnvarspec $nextrhs {*}$nexttail]] #debug.punk.pipe {>>> results: $results} 1 set d [_multi_bind_result $initial_returnvarspec $results] return [_handle_bind_result $d] @@ -1998,7 +2128,7 @@ namespace eval punk { } #rep_listname datatail - set segment_op ".=" + #set segment_op ".=" set assignment $initial_returnvarspec.=$e1 # this forces string rep of items within datatail -> set tailremaining [concat $assignment $datatail] @@ -2049,19 +2179,17 @@ namespace eval punk { if {[arg_is_script_shaped $segment_second_word]} { set segment_members_script_index 1 } - } else { set segment_first_word $e1 ;#don't look for scriptiness here.. can only be list or expr set segment_second_word [lindex $segment_members 0] if {[arg_is_script_shaped $segment_second_word]} { set segment_members_script_index 0 } - } #tailremaining includes x=y during the loop. set returnvarspec $initial_returnvarspec if {![llength $argslist]} { - catch {unset previous_result} ;# we want it unset for first iteration - differentiate from empty string + unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string } else { set previous_result $argslist } @@ -2084,24 +2212,47 @@ namespace eval punk { debug.punk.pipe {[a+ cyan bold] script segment: [lindex $segment_members $segment_members_script_index][a+]} 4 } - if {$i == $max_iterations} { - puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" - set more_pipe_segments 0 - } + #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position + set segment_result "" + if {[info exists previous_result]} { + set prevr $previous_result + } else { + set prevr "" + } + set pipedvars [dict create] + if {[string length $pipespec($i,in)]} { + #check the varspecs within the input piper + # - data and/or args may have been manipulated + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,in) $prevr] + #temp debug + #if {[dict exists $d result]} { + #set jjj [dict get $d result] + #puts "!!!!! [rep $jjj]" + #} + set inpipespec_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' + #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" + } + debug.punk.pipe {[a+] previous_iteration_result: $prevr[a+]} 6 + debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} + if {$i == $max_iterations} { + puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" + set more_pipe_segments 0 + } ##set dict_tagval [regexp -all -inline {(%[[:alnum:]]*%)} $segment_members] ;# e.g %args% %args% %data% %data% #set dict_segment_tags [regexp -all -inline {(%[[:alnum:]]*%)} $segment_members] ;# e.g %args% %args% %data% %data% # set dict_segment_tags [dict create] - - set tagmap [lmap v $segment_members {punk::get_tags $v}] debug.punk.pipe.var {TAGMAP([llength $tagmap]): $tagmap} 5 - #we definitely don't want to look for tags in scripts - would interfere with sub/nested pipelines set si 0 foreach seg $segment_members { @@ -2114,30 +2265,16 @@ namespace eval punk { incr si } set segment_has_tags [dict size $dict_segment_tags] - debug.punk.pipe.var {segment_tags: $dict_segment_tags} 5 debug.punk.pipe.rep {[rep_listname segment_members]} 4 - set segment_result "" - if {[info exists previous_result]} { - set prevr $previous_result - } else { - set prevr "" - } - set pipedvars [dict create] - if {[string length $pipespec($i,in)]} { - #check the varspecs within the input piper - # - data and/or args may have been manipulated - set d [apply {{mv res} { - punk::_multi_bind_result $mv $res -levelup 1 - }} $pipespec($i,in) $prevr] - set inpipespec_result [_handle_bind_result $d] - set pipedvars [dict get $d setvars] - set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' - #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" - } - debug.punk.pipe {[a+] previous_iteration_result: $prevr[a+]} 6 + + + + + + #whether the arguments have %v% tags or not - apply any modification from the piper argspecs (script will use modified args/data) if {[dict exists $pipedvars "datalist"]} { @@ -2229,7 +2366,6 @@ namespace eval punk { if {(![llength $segment_members_script_index]) && $segment_op eq ".="} { - #set subresult [uplevel 1 [list ::punk::match_exec $returnvarspec $rhs $segment_members_filled]] if {[string index $rhs 0] eq "\{"} { if {[llength $segment_members_filled] == 1} { if {[string index $rhs end] eq "\}"} { @@ -2254,10 +2390,8 @@ namespace eval punk { if {![catch {uplevel 1 [list expr $e]} evaluated]} { #set forward_result $evaluated - set d [_multi_bind_result $returnvarspec [punk::K $evaluated [unset evaluated]]] - set r [_handle_bind_result $d] - #return $r - set segment_result $r + set d [_multi_bind_result $returnvarspec [lindex [list $evaluated [unset evaluated]] 0 ]] + set segment_result [_handle_bind_result $d] } else { set msg "pipesyntax" append msg "Attempted to evaluate as expression '$e'\n" @@ -2272,9 +2406,7 @@ namespace eval punk { if {![catch {uplevel 1 [list expr $rhs {*}[lrange $segment_members_filled 1 end]]} evaluated]} { set forward_result $evaluated set d [_multi_bind_result $returnvarspec $forward_result] - set r [_handle_bind_result $d] - #return $r - set segment_result $r + set segment_result [_handle_bind_result $d] } else { set msg "pipesyntax" append msg "Attempted to evaluate as expression\n" @@ -2302,22 +2434,77 @@ namespace eval punk { #debug.punk.pipe {[a+ green bold]forward_result: $forward_result[a+]} 4 #debug.punk.pipe.rep {[a+ yellow bold]forward_result REP: [rep $forward_result][a+]} 4 - set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] - set r [_handle_bind_result $d] - set segment_result $r - #puts stderr ">>forward_result: $forward_result segment_result $r" + #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] + + set segment_result [_handle_bind_result $d] + #puts stderr ">>forward_result: $forward_result segment_result $segment_result" } } elseif {$segment_op eq "="} { - set segment_result [uplevel 1 [list ::punk::match_assign $returnvarspec $rhs [lrange $segment_members_filled 1 end]]] - #review - #set forward_result $segment_result + #set segment_result [uplevel 1 [list ::punk::match_assign $returnvarspec $rhs [lrange $segment_members_filled 1 end]]] + #slightly different semantics for assigment + set segment_tail [lrange $segment_members 1 end] ;#exclude the x=y + #set segment_members_filled $segment_members + if {!$segment_has_tags} { + if {[dict exists $dict_tagval %data%]} { + lappend segment_members_filled {*}[dict get $dict_tagval %data%] + } + } + set filled_tail [lrange $segment_members_filled 1 end] + + #puts stdout ">>> rhs:'$rhs' segment_members:$segment_members segment_tail:$segment_tail filled_tail:'$filled_tail'" + + if {(![llength $rhs]) && (![llength $segment_tail])} { + #no rhs and no values directly in segment + set list_mode 1 + } elseif {[llength $rhs]} { + set list_mode 1 + } else { + #there is a space after = and also at least one value already present in the tail (even before pipeargs applied) + set list_mode 0 + } + + if {$list_mode == 1} { + if {!$segment_has_tags} { + if {![llength $rhs]} { + set value [purelist] + } else { + set value [purelist $rhs] + } + if {[dict exists $dict_tagval %data%]} { + lappend segment_tail {*}[dict get $dict_tagval %data%] + } + lappend value {*}$segment_tail + } else { + set value $rhs + if {[llength $filled_tail] > 0} { + lappend value {*}$filled_tail + } + } + + } else { + #single value mode (no rhs and 1 or more vals) + if {[llength $filled_tail] == 0} { + set value [purelist] + } elseif {[llength $filled_tail] == 1} { + set value [lindex $filled_tail 0] + } else { + puts stderr "= assignment segment values: $filled_tail" + error "= unable to assign multiple values" + } + } + + set d [_multi_bind_result $returnvarspec [lindex [list $value [unset value ]] 0]] + set segment_result [_handle_bind_result $d] + + } elseif {[llength $segment_members_script_index]} { #script debug.punk.pipe {[a+ cyan bold].. evaluating as script[a+]} 2 @@ -2336,6 +2523,7 @@ namespace eval punk { } set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list + #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" set add_argsdata 1 if {[dict exists $dict_tagval "%argsdata%"]} { set argsdatalist [dict get $dict_tagval "%argsdata%"] @@ -2351,6 +2539,7 @@ namespace eval punk { } } + debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 if {!$add_argsdata} { debug.punk.pipe {APPLY1: args:$segmentargnames} 4 #puts stderr " script: $script" @@ -2362,15 +2551,16 @@ namespace eval punk { #puts stderr " script: $script" #puts stderr " vals: $segmentargvals $argsdatalist" #set evaluation [apply [list [concat $segmentargnames argsdata] $script ::] {*}$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 argsdata] $script ::] {*}$segmentargvals $argsdatalist]] } - #set forward_result $evaluation - set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] - set r [_handle_bind_result $d] - set segment_result $r + debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 + #puts "---> rep script evaluation result: [rep $evaluation]" + #set forward_result $evaluation + #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] + set d [_multi_bind_result $returnvarspec [lindex [list $evaluation [unset evaluation]] 0]] + set segment_result [_handle_bind_result $d] } else { #tags ? #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 @@ -2395,7 +2585,8 @@ namespace eval punk { } } set cmdline_result [uplevel 1 [concat $rhs $segment_members_filled]] - set d [_multi_bind_result $returnvarspec [punk::K $cmdline_result [unset cmdline_result]]] + #set d [_multi_bind_result $returnvarspec [punk::K $cmdline_result [unset cmdline_result]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdline_result [unset cmdline_result]] 0 ]] #multi_bind_result needs to return a funcl for rhs of: #lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] @@ -2404,17 +2595,14 @@ namespace eval punk { #The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. #NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result - set r [_handle_bind_result $d] - set segment_result $r + set segment_result [_handle_bind_result $d] } #the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section #It may however make a good debug point #puts stderr "segment $i segment_result:$segment_result" - - - + debug.punk.pipe.rep {[rep_listname segment_result]} 3 @@ -2477,7 +2665,8 @@ namespace eval punk { } else { set possible_assignment [lindex $segment_members 0] - if {[regexp $re_dot_assign $possible_assignment _ returnvarspec rhs]} { + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { set segment_op ".=" if {![string length $rhs]} { set segment_first_word [lindex $segment_members 1] @@ -2490,7 +2679,8 @@ namespace eval punk { set segment_first_word $rhs set segment_second_word [lindex $segment_members 1] } - } elseif {[regexp $re_assign $possible_assignment _ returnvarspec rhs]} { + } elseif {[regexp {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { + #set re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} set segment_op "=" #never scripts set segment_first_word [lindex $segment_members 1] @@ -2539,7 +2729,8 @@ namespace eval punk { #---------------- #for var="val {a b c}" #proc ::punk::val {{v {}}} {tailcall lindex $v} - proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version + #proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version + proc ::punk::val [list [list v [purelist]]] {return $v} #---------------- #can't use know - because we don't want to return before original unknown body is called. @@ -2561,10 +2752,9 @@ namespace eval punk { # # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. - know {[expr $args] || 1} { - #todo - repl output info that it was evaluated as an expression - expr $args - } + #todo - repl output info that it was evaluated as an expression + #know {[expr $args] || 1} {expr $args} + know {[expr $args] || 1} {tailcall expr $args} #it is significantly faster to call a proc like this than to inline it in the unknown proc proc ::punk::range {from to args} { @@ -2572,43 +2762,51 @@ namespace eval punk { incr from -1 return [lmap v [lrepeat $count 0] {incr from}] } - know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0 0] -> from to]} { - punk::range $from $to - } - #if {[info proc ::punk::_unknown] eq ""} {rename unknown ::punk::_unknown} + know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0 0] -> from to]} {punk::range $from $to} - - proc ::punk::_unknown_assign_dispatch {partzerozero varspecs rhs arglist} { + proc ::punk::_unknown_assign_dispatch {partzerozero varspecs rhs args} { set tail [lassign $args hd] if {$hd ne $partzerozero} { regexp $punk::re_assign $hd _ varspecs rhs } - tailcall ::punk::match_assign $varspecs $rhs $tail - } + #tailcall ::punk::match_assign $varspecs $rhs $tail + return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] + - #variable re_assign {^([^\r\n=\{]*)=(.*)} - know {[regexp $punk::re_assign [lindex $args 0 0] partzerozero varspecs rhs]} { - #if {![string length $varspecs]} { - #todo allow = with novar and just return value - #error "usage varspecs=val varspecs cannot be empty string using this syntax. Use ''set {} val' if you want to set a var with an empty-string name" - #} + #puts >>1>[rep $result] + 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' + return $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + error $result + } else { + #puts >>2>[rep $result] + return $result + } + } + } + #variable re_assign {^([^\r\n=\{]*)=(.*)} #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list #e.g x=a\nb c #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained - set tail [lassign $args hd] - if {$hd ne $partzerozero} { - regexp $punk::re_assign $hd _ varspecs rhs - } + know {[regexp $punk::re_assign [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall ::punk::_unknown_assign_dispatch $partzerozero $varspecs $rhs {*}$args} - #must be tailcall so match_assign runs at same level as the unknown proc - tailcall ::punk::match_assign $varspecs $rhs $tail - } - #ensure == is after = in know sequence - #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions - know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} { + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #know {[regexp $punk::re_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # set tail [lassign $args hd] + # if {$hd ne $partzerozero} { + # regexp $punk::re_assign $hd _ varspecs rhs + # } + # # tailcall so match_assign runs at same level as the unknown proc + # tailcall ::punk::match_assign $varspecs $rhs $tail + #} + + + proc ::punk::_unknown_compare {val1 val2 args} { if {![string length [string trim $val2]]} { if {[llength $args] > 1} { #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" @@ -2638,26 +2836,49 @@ namespace eval punk { } } } + #ensure == is after = in know sequence + #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions + know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} #.= must come after = here to ensure it comes before = in the 'unknown' proc #set punk::re_dot_assign {([^=]*)\.=(.*)} #know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { # set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] # tailcall ::punk::match_exec $varspecs $rhs {*}$tail # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] - #} - know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # } + # + proc ::punk::_unknown_dot_assign_dispatch {partzerozero varspecs rhs args} { set argstail [lassign $args hd] - #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! - #avoid using the return from expr and it works: expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } - - tailcall ::punk::match_exec $varspecs $rhs {*}$tail - #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + return [uplevel 1 [list ::punk::pipeline .= $varspecs $rhs {*}$tail]] + + #puts >>1>[rep $result] + 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 $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + puts "))) $result" + error $result + } else { + #puts >>2>[rep $result] + puts ")))) $result" + return $result + } + } } - #know {[regexp {^=([^=]*)} [lindex $args 0] _ v1]} { - # set calc [concat $v1 [lrange $args 1 end]] - # puts stderr "= $calc" - # return [expr $calc] + #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # set argstail [lassign $args hd] + # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! + # #avoid using the return from expr and it works: + # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + # + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] #} } @@ -2670,23 +2891,63 @@ namespace eval punk { proc % {args} { set arglist [lassign $args assign] ;#tail, head if {$assign eq ".="} { - set cmdlist [list ::punk::match_exec "" "" {*}$arglist] + tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] } elseif {$assign eq "="} { - set cmdlist [list ::punk::match_assign "" "" $arglist] - } elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { - set re_equals {^([^ \t\r\n=\{]*)=$} - set re_dotequals {^([^ \t\r\n=\{]*)\.=$} - if {[regexp $re_dotequals $assign _ returnvarspecs]} { - set cmdlist [list ::punk::match_exec $returnvarspecs "" {*}$arglist] - } elseif {[regexp $re_equals $assign _ returnvarspecs]} { - set cmdlist [list ::punk::match_assign $returnvarspecs "" $arglist] + tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] + } + + #maint - punk::arg_is_script_shaped (inlined) + if {[string first " " $assign] >= 0} { + set is_script 1 + } elseif {[string first \n $assign] >= 0} { + set is_script 1 + } elseif {[string first ";" $assign] >= 0} { + set is_script 1 + } elseif {[string first \t $assign] >= 0} { + set is_script 1 + } else { + set is_script 0 + } + + if {!$is_script && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set re_equals {^([^ \t\r\n=\{]*)=$} + if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { error "pipesyntax punk::% unable to interpret pipeline '$args'" } } else { - set cmdlist [list ::punk::match_exec "" "" {*}$args] + if {$is_script} { + set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] + } else { + set cmdlist [list ::punk::pipeline ".=" "" "" {*}$args] + } } tailcall {*}$cmdlist + + + #result-based mismatch detection can probably never work nicely.. + #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! + # + set result [uplevel 1 $cmdlist] + #pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' + #.. but if we use certain string methods - we shimmer the case where the main result is a list + #string match doesn't seem to change the rep.. though it does generate a string rep. + #puts >>1>[rep $result] + 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' + return $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + error $result + } else { + #puts >>2>[rep $result] + return $result + } + } } proc ispipematch {args} { @@ -2701,13 +2962,13 @@ namespace eval punk { set arglist [lassign $args assign] if {$assign eq ".="} { - set cmdlist [list ::punk::match_exec "" "" {*}$arglist] + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] } elseif {$assign eq "="} { - set cmdlist [list ::punk::match_assign "" "" $arglist] + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::match_exec $returnvarspecs $rhs {*}$arglist] + set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::match_assign $returnvarspecs $rhs $arglist] + set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] } else { set cmdlist $args #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] @@ -2715,9 +2976,10 @@ namespace eval punk { if {[catch {uplevel 1 $cmdlist} result]} { #debug.punk.pipe {pipematch error $result} 4 - if {[string match "binding*mismatch*" $result]} { + if {[string match "binding mismatch*" $result]} { #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]} { @@ -2726,9 +2988,23 @@ namespace eval punk { #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]] + } + } #debug.punk.pipe {pipematch result $result } 4 #return [dict create ok [dict create result $result]] - return [list ok [list result $result]] } } @@ -2746,13 +3022,13 @@ namespace eval punk { variable re_assign #what if we get passed a script block containing = ?? e.g {error x=a} if {$assign eq ".="} { - set cmdlist [list ::punk::match_exec "" "" {*}$arglist] + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] } elseif {$assign eq "="} { - set cmdlist [list ::punk::match_assign "" "" $arglist] + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::match_exec $returnvarspecs $rhs {*}$arglist] + set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::match_assign $returnvarspecs $rhs $arglist] + set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] } else { debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a+]} 0 set cmdlist $args @@ -2770,7 +3046,7 @@ namespace eval punk { set nomatchvar $errordict error $result } - if {[string match "binding*mismatch*" $result]} { + if {[string match "binding mismatch*" $result]} { #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 @@ -2795,30 +3071,31 @@ namespace eval punk { #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 set arglist [lassign $args assign] if {$assign eq ".="} { - set cmdlist [list ::punk::match_exec "" "" {*}$arglist] + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] } elseif {$assign eq "="} { - set cmdlist [list ::punk::match_assign "" "" $arglist] + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] } elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { - set re_equals {^([^ \t\r\n=\{]*)=$} - set re_dotequals {^([^ \t\r\n=\{]*)\.=$} - if {[regexp $re_dotequals $assign _ returnvarspecs]} { - set cmdlist [list ::punk::match_exec $returnvarspecs "" {*}$arglist] - } elseif {[regexp $re_equals $assign _ returnvarspecs]} { - set cmdlist [list ::punk::match_assign $returnvarspecs "" $arglist] + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set re_equals {^([^ \t\r\n=\{]*)=$} + if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { error "pipesyntax punk::% unable to interpret pipeline '$args'" } } else { - set cmdlist [list ::punk::match_exec "" "" {*}$args] + #script? + set cmdlist [list ::punk::pipeline .= "" "" {*}$args] } - if {[catch {uplevel 1 $cmdlist} result]} { + if {[catch {uplevel 1 [list if 1 $cmdlist]} result]} { #puts stderr "====>>> $result" if {[string match "pipesyntax*" $result]} { error $result } - if {[string match "binding*mismatch*" $result]} { + if {[string match "binding mismatch*" $result]} { #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]] @@ -2863,6 +3140,32 @@ namespace eval punk { set switchargs $args 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 affecting it, but is less performant. (particularly in global scope.. but that isn't an important usecase) + proc pipeswitchc {pipescript args} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars switchargs] + set vars [lreplace $vars $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + lappend binding [list switchargs $args] + apply [list $binding $pipescript [uplevel 1 namespace current]] + } + + + proc ansi+ {args} { variable ansi_disabled if {$ansi_disabled == 1} { @@ -3387,7 +3690,7 @@ namespace eval punk { return $linelist } - # important for match_exec & match_assign + # important for pipeline & match_assign # lineval verbatim|trimmed proc linelist {text {lineval verbatim}} { if {$lineval ni [list verbatim trimmed]} {error "linelist 2nd argument valid values are 'verbatim' or 'trimmed'"} @@ -3637,16 +3940,22 @@ namespace eval punk { interp alias {} % {} punk::% interp alias {} pipeswitch {} punk::pipeswitch + interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct interp alias {} pipecase {} punk::pipecase interp alias {} pipematch {} punk::pipematch interp alias {} ispipematch {} punk::ispipematch interp alias {} pipenomatchvar {} punk::pipenomatchvar + interp alias {} pipeset {} punk::pipeset + interp alias {} listset {} punk::listset ;#identical to pipeset + interp alias {} nscommands {} ,'ok@0.= { upvar caseresult caseresult if {![info exists ns]} { set ns "" } + #by using pipeswitch instead of pipeswitchc - we give the ability* for the switch script block to affect vars in the calling scope + # (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster ) pipeswitch { #no glob chars present pipecase \ @@ -3661,19 +3970,19 @@ namespace eval punk { uplevel #0 [list info commands ${input}] } } + + } |data@@ok/result> {set data} |> {lmap v $data {namespace tail $v}} |> lsort |> {join $data \n}