diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 045697bf..b34d5350 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -134,15 +134,15 @@ namespace eval punk { #----------------------------------- # todo - load initial debug state from config - debug on punk.unknown + debug off punk.unknown debug level punk.unknown 1 - debug on punk.pipe + debug off punk.pipe debug level punk.pipe 4 - debug on punk.pipe.var - debug level punk.pipe.var 1 - debug on punk.pipe.args - debug level punk.pipe.args 1 - debug on punk.pipe.rep 1 + debug off punk.pipe.var + debug level punk.pipe.var 4 + debug off punk.pipe.args + debug level punk.pipe.args 3 + debug off punk.pipe.rep 2 debug header "dbg> " @@ -187,13 +187,16 @@ namespace eval punk { #equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. expr {($a && 1) == ($b && 1)} } + #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? (^&~) ? proc boolean_almost_equal {a b} { - if {[string is double --strict $a]} { + if {[string is double -strict $a]} { if {[float_almost_equal $a 0]} { set a 0 } } - if {[string is double --strict $b]} { + if {[string is double -strict $b]} { if {[float_almost_equal $b 0]} { set b 0 } @@ -295,11 +298,90 @@ namespace eval punk { } return $varlist } + proc splitstrposn {s p} { + if {$p <= 0} { + if {$p == 0} { + list "" $s + } else { + list $s "" + } + } else { + scan $s %${p}s%s + } + } + proc splitstrposn_nonzero {s p} { + scan $s %${p}s%s + } 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 in_brackets 0 - set varspecs [string trimleft $varspecs,] + #set varspecs [string trimleft $varspecs ,] + set token "" + #if {[string first "," $varspecs] <0} { + # return $varspecs + #} + set first_term -1 + set token_index 0 ;#index of terminal char within each token + set prevc "" + foreach c [split $varspecs ""] { + if {$in_brackets} { + append token $c + if {$c eq ")"} { + set in_brackets 0 + } + } else { + if {$c eq ","} { + #lappend varlist [splitstrposn $token $first_term] + set var $token + set spec "" + if {$first_term > 0} { + lassign [scan $token %${first_term}s%s] var spec + } else { + if {$first_term == 0} { + set var "" + set spec $token + } + } + lappend varlist [list $var $spec] + set token "" + set token_index -1 ;#reduce by 1 because , not included in next token + set first_term -1 + } else { + append token $c + if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { + set first_term $token_index + } elseif {$c eq "("} { + set in_brackets 1 + } + } + } + set prevc $c + incr token_index + } + if {[string length $token]} { + #lappend varlist [splitstrposn $token $first_term] + set var $token + set spec "" + if {$first_term > 0} { + lassign [scan $token %${first_term}s%s] var spec + } else { + if {$first_term == 0} { + set var "" + set spec $token + } + } + lappend varlist [list $var $spec] + } + return $varlist + } + proc _split_var_key_at_unbracketed_comma1 {varspecs} { + set varlist [list] + set var_terminals [list "@" "/" "#"] + set in_brackets 0 + #set varspecs [string trimleft $varspecs ,] set token "" #if {[string first "," $varspecs] <0} { # return $varspecs @@ -350,6 +432,19 @@ namespace eval punk { return $varlist } + proc fp_restructure {selector data} { + if {$selector eq ""} { + fun=.= {val $input} and always break + set lhs "" + set rhs "" + #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 subpath [join [lrange $subindices 0 $i_keyindex] /] + set lhs $subpath set assigned "" set get_not 0 set already_assigned 0 if {$index eq "#"} { set active_key_type "list" - set assigned [llength $leveldata] - set already_assigned 1 + if {![catch {llength $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-list + break + } } elseif {$index eq "##"} { set active_key_type "dict" - set assigned [dict size $leveldata] - set already_assigned 1 + if {![catch {dict size $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-dict + break + } } elseif {$index eq "@"} { set active_key_type "list" #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey @@ -381,118 +490,280 @@ namespace eval punk { #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set action ?mismatch-list-index-out-of-range + break + } set assigned [lindex $leveldata $index] set already_assigned 1 + } else { if {$index eq "@@"} { - set active_key_type "list" - #NOTE: This may seem inconsistent with @@key, which sets the active_key_type to dict, however it's important to set this to list. - #The reason is that x@@.= val $somedict will return {key val} .. but if we leave the active_key_type as dict - #the only possible subindex would be x@@/key - which defeats the purpose of @@ allowing us to retrieve k,v pairs where we don't know k - #By setting to 'list' we can use x@@/0 to get the name x@@/1 to get the value. - #To keep navigating into sub-dicts we can use x@@/1/@@key/etc - #An alternative could be to set active_key_type as dict and automatically access subelements. - #ie x@@/subkey - but this is too surprising (too much magic). - #e.g for dict {a {x y}} x@@ returning a {x y} but x@@/x = y is likely to cause confusion and errors - #better is: + set active_key_type "dict" + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc #x@@ = a {x y} - #x@@/0 = a - #x@@/1 = x y + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} # - set subpath [join [lrange $subindices 0 $i_keyindex] /] + #set subpath [join [lrange $subindices 0 $i_keyindex] /] + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } set next_this_level [incr v_dict_idx($subpath)] set keyindex [expr {$next_this_level -1}] - if {($keyindex + 1) <= [dict size $leveldata]} { + if {($keyindex + 1) <= $dsize} { set k [lindex [dict keys $leveldata] $keyindex] set assigned [list $k [dict get $leveldata $k]] + set already_assigned 1 } else { - set assigned "" + set action ?mismatch-dict-index-out-of-range + break } - set already_assigned 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 if {[dict exists $leveldata $key]} { set assigned [dict get $leveldata $key] } else { - #for consistency with lindex out of range setting var to empty string - we will do same for non existent dict key rather than unset - #This stops us *directly* using @@key for pattern-match testing that key exists - but we can acheive matching using the count mechanism. - #e.g 0+@#@key ? (where 0 is empty list/string and -1 means key not found) - set assigned "" + set action ?mismatch-dict-key-not-found + break } set already_assigned 1 } elseif {[string match @* $index]} { set active_key_type "list" set index [string trimleft $index @] - - } elseif {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { - #not- only valid at beginning if selector is a range. - #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"} { - set active_key_type "list" - set assigned [lindex $leveldata 0]; set already_assigned 1 - } elseif {$index in [list "not-head" "not-0"]} { - set active_key_type "list" - #set selector "tail"; set get_not 0 - set assigned [lrange $leveldata 1 end]; set already_assigned 1 - } elseif {$index eq "not-end"} { - set active_key_type "list" - set assigned [lrange $leveldata 0 end-1]; set already_assigned 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] - } - - } else { # } + + + if {!$already_assigned} { + if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { + #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"} { + set active_key_type "list" + + set assigned [lindex $leveldata 0]; set already_assigned 1 + } elseif {$index in [list "not-head" "not-0"]} { + set active_key_type "list" + #set selector "tail"; set get_not 0 + set assigned [lrange $leveldata 1 end]; set already_assigned 1 + } elseif {$index eq "not-end"} { + set active_key_type "list" + set assigned [lrange $leveldata 0 end-1]; set already_assigned 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] + } + } + } + } if {!$already_assigned} { + + #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" + if {$active_key_type in [list "" "list"]} { set active_key_type "list" + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) if {$index in [list "head" 0]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$len == 0} { + set action ?mismatch-list-index-out-of-range-empty + break + } #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 "tail"} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$len == 0} { + set action ?mismatch-list-index-out-of-range + break + } + 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 + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + 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. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } set assigned [lrange $leveldata 1 end] + } elseif {$index eq "anylist"} { + #allow returning of entire list even if empty + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned $leveldata + } elseif {$index eq "any"} { + #no list checking.. + 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 + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + 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 + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict values $leveldata] + } elseif {$index eq "end"} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$len < 1} { + set action ?mismatch-list-index-out-of-range + } + set assigned [lindex $leveldata end] } elseif {[string is integer -strict $index]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$index+1 > $len || $index < 0} { + set action ?mismatch-list-index-out-of-range + break + } if {$get_not} { #already handled not-0 set assigned [lreplace $leveldata $index $index] } else { set assigned [lindex $leveldata $index] } - } elseif {[regexp {^(end)$|^end[-+]{1,2}([0-9]+)$} $index]} { - if {$get_not} { - set assigned [lreplace $leveldata $index $index] + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #leave the - from the end- as part of the offset + set offset [expr $endspec] ;#don't brace! + if {$offset > 0 || abs($offset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {[string is integer -strict $start]} { + if {$start+1 > $len || $start < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$start eq "end"} { + #ok + } else { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0 || abs($startoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {[string is integer -strict $end]} { + if {$end+1 > $len || $end < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$end eq "end"} { + #ok + } else { + set endoffset [string range $end 3 end] ;#include the - from end- + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0 || abs($endoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } } else { - set assigned [lindex $leveldata $index] + error $listmsg } - } 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 assigned [lreplace $leveldata $start $end] + } elseif {[string first - $index] > 0} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #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 + } + lassign $parts start end + if {$start+1 > $len || $end+1 > $len} { + set action ?mismatch-not-a-list + break + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } } else { - set assigned [lrange $leveldata $start $end] + error $listmsg } + } else { - #puts stderr "selector:$selector" #keyword 'pipesyntax' at beginning of error message - set msg "pipesyntax Unable to interpret subindex $index\n" - append msg "selector: $selector\n" - append msg "@ 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 msg "Additional accepted keywords include: head tail\n" - append msg "Use var@@key to treat value as a dict and retrieve element at key" - error $msg + error $listmsg } } else { #treat as dict key @@ -500,19 +771,25 @@ namespace eval punk { if {[dict exists $leveldata $index]} { set assigned [dict get $leveldata $index] } else { - set assigned "" + set action ?mismatch-dict-key-not-found + break } } } set leveldata $assigned - if {![llength $leveldata]} { - break - } + set rhs $leveldata + #don't break on empty data - operations such as # and ## can return 0 + #if {![llength $leveldata]} { + # break + #} incr i_keyindex } - return $leveldata + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + 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 @@ -522,14 +799,13 @@ namespace eval punk { #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 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 - set returndict [dict create ismatch 0 result "" setvars {} unsetvars {}] if {![string length $multivar]} { - #treat the absence of a var as a match to anything - dict set returndict ismatch 1 - dict set returndict result $data - return $returndict + #treat the absence of a pattern as a match to anything + return [dict create ismatch 1 result $data setvars {} unsetvars {}] } + set returndict [dict create ismatch 0 result "" setvars {} unsetvars {}] set defaults [list -unset 0 -levelup 2 ] set opts [dict merge $defaults $args] @@ -540,11 +816,6 @@ namespace eval punk { #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 - if {[string first "," $multivar] >=0} { - set varspeclist [_split_at_unbracketed_comma $multivar] - } else { - set varspeclist [list $multivar] - } set varkeylist [_split_var_key_at_unbracketed_comma $multivar] #puts stdout "\n varkeylist: $varkeylist\n" @@ -552,29 +823,104 @@ namespace eval punk { #segment returntype is indicated by leading % - #mutually exclusive - atom/pin - set map [list "" ' ^] ;#0 = don't-care/other 1 = atom 2 = pin - #set var_class [lmap var $varspeclist {expr {([set m [lsearch $map [string index $var 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] - #puts stdout "\n var_class: $var_class\n" - # e.g {a 0} {'b 1} {c 0} {^x(a,b) 2} + #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]}}] + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + #8 - numeric + + 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 expected_values [list] + #set expected_values [lmap v $var_names {list $v "-" ""}] + #e.g {a = abc} {b unset ""} + foreach v_key $varkeylist { + 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] + } 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 + } + } + } + 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 + } - set var_class [lmap var $varkeylist {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] #puts stdout "\n var_class: $var_class\n" + # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} - #raw varspecs without pin/atom modifiers - #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [string range [lindex $varinfo 0] 1 end] : [lindex $varinfo 0]}}] - #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" - - - 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]}}] + #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 ) - #set var_names [lmap v $varspecs_trimmed {expr {([set p [string first @ $v]] >= 0) ? [string range $v 0 $p-1] : $v}}] - set var_names [lmap v $varspecs_trimmed {lindex $v 0}] - #puts stdout "\nvar_names: $var_names\n" + #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 @@ -582,8 +928,8 @@ namespace eval punk { #jn #member lists of returndict which will be appended to in the initial value-retrieving loop - set returndict_setvars [dict get $returndict setvars] - set returndict_unsetvars [dict get $returndict unsetvars] + set returndict_setvars [dict get $returndict setvars] + set returndict_unsetvars [dict get $returndict unsetvars] set assigned_values [list] @@ -601,12 +947,9 @@ namespace eval punk { # unset # question mark versions are temporary - awaiting a check of action vs var_class # e.g ?set may be changed to matchvar or matchatom or set - set var_actions [lmap v $var_names {expr {[list $v "" ""]}}] - #e.g {a = abc} {b unset ""} - set expected_values [lmap v $var_names {list $v "-" ""}] - debug.punk.pipe.var "initial map expected_values: $expected_values" 5 + debug.punk.pipe.var {initial map expected_values: $expected_values} 5 set returnval "" @@ -622,9 +965,9 @@ namespace eval punk { set vspec [join $v_and_key ""] lassign $v_and_key v vkey + set already_actioned 0 ;#especially for list/dict subkeys so we don't set the default ?set action if we've already set it to something else set assigned "" #The binding spec begins at first @ or # or / - set firstat [string first "@" $vkey] #set firstq [string first "'" $vspec] #set v [lindex $var_names $i] @@ -653,36 +996,111 @@ namespace eval punk { - set after_first_at [string range $vkey $firstat+1 end] - set vkey [string trimleft $vkey /] - if {$vkey eq "@"} { - #no dict key following @, this is a positional spec for list - set assigned [lindex $data $v_list_idx(@)] + #puts stderr ">>>>>>>>>>>>>>>> $vkey" + + set subindices [split $vkey /] + if {[string is digit -strict [join $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 in [list 0 head]} { + 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 "@"} { + #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 } - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned 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 keypath [string range $vkey 1 end] + set rawkeylist [split $vkey /] ;#first key retains @@ - may be just '@@' + set keypath [string range $vkey 2 end] set keylist [split $keypath /] - if {([lindex $keylist 0] ne "@@") && [lsearch $keylist @*] == -1} { + if {([lindex $rawkeylist 0] ne "@@") && [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 @@ -691,139 +1109,58 @@ namespace eval punk { # uplevel $lvlup [list set $v $assigned] #} } else { - #for consistency with lindex out of range setting var to empty string - we will do same for non existent dict key rather than unset - #This stops us *directly* using @@key for pattern-match testing that key exists - but we can acheive matching using the count mechanism. - #e.g 0+@@key/# or 0+@@key/## ? (where 0 is empty list/string and -1 means key not found) - set assigned "" - lset var_actions $i 1 ?set - lset var_actions $i 2 "" + #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 - set assigned [destructure $vkey $data] - lset var_actions $i 1 ?set + 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 + set already_actioned 1 } } 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 - #set selector $after_first_at - set selector $vkey - - #puts stderr "selector:$selector leveldata: $data" - set leveldata $data - - set subindices [split $selector /] - set chars [join $subindices ""] - if {[string is digit -strict $chars]} { - #pure numeric keylist - put straight to lindex - puts stderr "lindex $leveldata $subindices" - set assigned [lindex $leveldata {*}$subindices] - } elseif {[string first "/@@" $selector] >=0 || [string first "/#" $selector] >= 0} { + + if {[string first "/@@" $vkey] >=0 || [string first "/#" $vkey] >= 0} { #compound destructuring required - mix of list and dict keys - set assigned [destructure $vkey $data] - lset var_actions $i 1 ?set + 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 + set already_actioned 1 } else { - set i_keyindex 0 - foreach index $subindices { - if {$index eq "@"} { - #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 isatom $nm" - if {$act in [list "?matchatom-set" "?set"]} { - lset var_actions $i 1 matchatom-set - if {$nm eq $val} { - lset match_state $i 1 - } - lset expected_values $i [list $nm match $nm] - } elseif {$act eq "?unset"} { - #doesn't make sense for an atom ? - should fail match - lset expected_values $i [list $nm match $nm] - } else { - lset expected_values $i [list $nm unkown $nm] - } - } elseif {$ispin} { + + 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" if {$act in [list "?set" "?matchvar-set"]} { lset var_actions $i 1 matchvar-set @@ -920,12 +1262,39 @@ namespace eval punk { upvar $lvlup $nm the_var #if {![catch {uplevel $lvlup [list set $nm]} existingval]} {} if {![catch {set the_var} existingval]} { - lset match_state $i [expr {$existingval eq $val}] - lset expected_values $i [list $nm match $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] + } elseif {$isglob} { + #isglob due to 2nd classifier ^* + lset expected_values $i [list spec $nm info match-lhs-glob lhs $existingval rhs $val] + } elseif {$isnumeric} { + + if {[string is integer -strict $existingval]} { + set isint 1 + lset expected_values $i [list spec $nm info match-lhs-int lhs $existingval rhs $val] + } elseif {[string is double -strict $existingval]} { + set isdouble 1 + lset expected_values $i [list spec $nm info match-lhs-double lhs $existingval rhs $val] + } + + } else { + #standard pin - single classifier ^var + 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] + break + } + } + } else { #puts stdout "var ^$nm 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 expected_values $i [list $nm failread ""] + lset match_state $i 0 + lset expected_values $i [list spec $nm info failread lhs ? rhs $val] + break } } if {$act in [list "?unset" "?matchvar-unset"]} { @@ -935,9 +1304,187 @@ namespace eval punk { lset match_state $i 1 } else { #attempt to unset a pinned var that has a value - non-match. ^x= will only match an unset variable x - lset expected_values $i [list $nm attempt-to-unset-pinned-var-with-value [set the_var]] + 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 ""] + 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 {$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 + } + if {[string is integer -strict $val]} { + if {$lhs == $val} { + 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] + break + } + } elseif {[string is double -strict $val]} { + #dragons. (and shimmering) + if {[string first "e" $val] != -1} { + #scientific notation - let expr compare + if {$lhs == $val} { + 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] + break + } + } elseif {[string is digit -strict [string trim $val -]] } { + #probably a wideint or bignum with no decimal point + #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . + #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. + #2 values further apart can compare equal while int-like ones closer together can compare different. + #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. + #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. + #string comparison can presumably always be used as an alternative. + # + #let expr compare + if {$lhs == $val} { + 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] + break + } + } else { + #review! if we're using float_almost_equal at all.. should we use it always? + if {[punk::float_almost_equal $lhs $val]} { + 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] + break + } + } + } else { + #unknown - todo warn? + if {$lhs == $val} { + 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] + break + } + } + } + } elseif {$isdouble} { + #dragons (and shimmering) + 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 + } + + if {[string first "e" $lhs] >= 0 || [string first "e" $val] >= 0} { + if {$lhs == $val} { + 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] + 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} { + 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] + 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]} { + 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] + break + } + } + } + } elseif {$isbool} { + #punk::boolean_equal $a $b + 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 boolean (&yes,&false,&1,&0 etc) in the pattern + } + + if {![catch {punk::boolean_almost_equal $lhs $val} ismatch]} { + if {$ismatch} { + 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] + 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] + break } + + } + } elseif {$isglob} { + 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 glob in the pattern + } + 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] + break + } + } + + } elseif {$ispin} { + #handled above.. leave case in place so we don't run else for pins } else { #puts stdout "==> $nm" @@ -953,7 +1500,10 @@ namespace eval punk { #Variable assignments (set/unset) should only occur down here, and only if we have a match #-------------------------------------------------------------------------- set match_count_needed [llength $var_actions] - set match_count [expr [join $match_state +]] ;#expr must be unbraced here + #set match_count [expr [join $match_state +]] ;#expr must be unbraced here + set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" + set match_count [llength $matches] + debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 @@ -966,12 +1516,8 @@ namespace eval punk { set i 0 foreach va $var_actions { lassign $va nm act val - set isatom [expr {[lindex $var_class $i 1] == 1}] - if {[string is double -strict $nm]} { - set isatom 1 - } - set ispin [expr {[lindex $var_class $i 1] == 2}] - if {(!$isatom) && (!$ispin)} { + 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 @@ -993,35 +1539,63 @@ namespace eval punk { #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 set vidx 0 - set mismatches [lmap m $match_state v $var_names {expr {$m != 1} ? {[list mismatch $v]} : {[list match $v]}}] - set mismatches_display [lmap m $match_state v $var_names {expr {$m != 1} ? {$v} : {[string repeat " " [string length $v]]}}] + set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + set var_display_names [list] + foreach v $var_names { + if {$v eq ""} { + lappend var_display_names {{}} + } else { + lappend var_display_names $v + } + } + 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 "vars/atoms: $var_names\n" + append msg "vars/atoms/etc: $var_names\n" append msg "mismatches: [join $mismatches_display { } ]\n" set i 0 + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) foreach mismatchinfo $mismatches { lassign $mismatchinfo status nm if {$status eq "mismatch"} { # nm 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] if {$varclass == 1} { set type "atom" - set e $nm } elseif {$varclass == 2} { set type "pinned var" - set e [lindex $expected_values $i 2] + } elseif {$varclass == 4} { + set type "int" + } elseif {$varclass == 5} { + set type "double" } else { set type "var" - set e "*" ;# non-atoms and non-pins should always match.. todo - review attempt to set as var instead of array? + #set e "*" ;# non-atoms and non-pins should always match.. todo - review attempt to set as var instead of array? } set lhs_tag "" - if {[lindex $expected_values $i 1] ne "match"} { - set lhs_tag "-[lindex $expected_values $i 1]" + 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 + } } - append msg " $type: '$nm' LHS$lhs_tag: '$e' vs RHS: '$val'\n" + append msg " $type: '$nm' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" } incr i } @@ -1032,10 +1606,10 @@ namespace eval punk { return $returndict } - if {![llength $varspeclist]} { + if {![llength $varkeylist]} { dict set returndict result $data } else { - #punk::assert {$i == [llength $varspeclist]} + #punk::assert {$i == [llength $varkeylist]} dict set returndict result $returnval } @@ -1184,6 +1758,13 @@ namespace eval punk { error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data instead of \$args." } + + #REVIEW! 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) + # #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) #%% is not a valid tag @@ -1296,8 +1877,8 @@ namespace eval punk { proc match_exec {initial_returnvarspec e1 args} { set fulltail $args unset args - debug.punk.pipe {call match_exec: '$initial_returnvarspec' '$e1' '$fulltail'} 9 - debug.punk.pipe.rep {[rep_listname fulltail]} 6 + #debug.punk.pipe {call match_exec: '$initial_returnvarspec' '$e1' '$fulltail'} 9 + #debug.punk.pipe.rep {[rep_listname fulltail]} 6 #temp @@ -1307,8 +1888,7 @@ namespace eval punk { #--------------------------------------------------------------------- # test if we have an initial x.=y.= or x.= y.= if {($e1 eq "") } { - set next1 [lindex $fulltail 0] - set nexttail [lrange $fulltail 1 end] + set nexttail [lassign $fulltail next1] ;#tail head } else { set next1 $e1 set nexttail $fulltail @@ -1324,34 +1904,37 @@ namespace eval punk { return $r } elseif {$next1 eq "pipecase"} { set msg "pipesyntax\n" - append msg "pipecase cannot return a value directly.\n" - append msg "Call pipecase from within a script block such as pipeswitch or apply." + 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 "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." error $msg } + #maintenance: punk::re_dot_assign + 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 $punk::re_dot_assign $next1 _ nextreturnvarspec nextrhs]} { + + if {[regexp $re_dot_assign $next1 _ nextreturnvarspec nextrhs]} { #non pipelined call to self - return result - debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 + #debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 set results [uplevel 1 [list ::punk::match_exec $nextreturnvarspec $nextrhs {*}$nexttail]] - debug.punk.pipe {>>> results: $results} 1 - + #debug.punk.pipe {>>> results: $results} 1 set d [_multi_bind_result $initial_returnvarspec $results] - set r [_handle_bind_result $d] - - return $r + return [_handle_bind_result $d] } - if {[regexp $punk::re_assign $next1 _ nextreturnvarspec nextrhs]} { + if {[regexp $re_assign $next1 _ nextreturnvarspec nextrhs]} { #non pipelined call to plain = assignment - return result - debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 + #debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 set results [uplevel 1 [list ::punk::match_assign $nextreturnvarspec $nextrhs $nexttail]] - debug.punk.pipe {>>> results: $results} 1 - + #debug.punk.pipe {>>> results: $results} 1 set d [_multi_bind_result $initial_returnvarspec $results] - set r [_handle_bind_result $d] - - return $r + return [_handle_bind_result $d] } } @@ -1362,8 +1945,6 @@ namespace eval punk { #|> data piper symbol #<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) # - set re_is_piper {^\|(.*)>$} ;#for use with lmap. captures forwarding argspecs within the |> pipe symbol (e.g |x@@key,y@end>) - set re_is_argpiper {^<(.*)\|$} set more_pipe_segments 1 ;#first loop @@ -1396,7 +1977,9 @@ namespace eval punk { set argslist [list] set argpipespec "" ;#argumentspec e.g a,b,c from $} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] #e.g for: a b c |> e f g |> h #set firstpipe_posn [lsearch $tailmap {| >}] @@ -1476,7 +2060,11 @@ namespace eval punk { } #tailremaining includes x=y during the loop. set returnvarspec $initial_returnvarspec - catch {unset previous_result} ;# to emphasize we want it unset for first iteration - differentiate from empty string + if {![llength $argslist]} { + catch {unset previous_result} ;# we want it unset for first iteration - differentiate from empty string + } else { + set previous_result $argslist + } set segment_result_list [list] set i 0 ;#segment id @@ -1485,19 +2073,12 @@ namespace eval punk { set pipespec(0,in) $inpipespec set pipespec(0,out) $outpipespec - set max_iterations 50 ;# configurable? -1 for no limit ? + set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. while {$more_pipe_segments == 1} { - set segment_result "" - if {[info exists previous_result]} { - set prevr $previous_result - } else { - set prevr "" - } #--------------------------------- debug.punk.pipe {[a+ yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a+]} 4 debug.punk.pipe {[a+ yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a+]} 4 debug.punk.pipe {[a+] inpipespec(prev [a+ yellow bold]|$pipespec($i,in)[a+]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a+])} 4 - debug.punk.pipe {[a+] previous_iteration_result: $prevr[a+]} 6 debug.punk.pipe {[a+ cyan bold] segment_members_script_index:$segment_members_script_index} 4 if {[llength $segment_members_script_index]} { debug.punk.pipe {[a+ cyan bold] script segment: [lindex $segment_members $segment_members_script_index][a+]} 4 @@ -1538,17 +2119,25 @@ namespace eval punk { 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 even if no %varname% tags present. + #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 r [_handle_bind_result $d] + 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"]} { @@ -1785,7 +2374,7 @@ namespace eval punk { } else { #tags ? #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 - if 1 { + if 0 { @@ -1874,7 +2463,7 @@ namespace eval punk { } - #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal command or script!) + #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) set segment_first_word "" set returnvarspec "" ;# the lhs of x=y set segment_op "" @@ -1888,7 +2477,7 @@ namespace eval punk { } else { set possible_assignment [lindex $segment_members 0] - if {[regexp $punk::re_dot_assign $possible_assignment _ returnvarspec rhs]} { + if {[regexp $re_dot_assign $possible_assignment _ returnvarspec rhs]} { set segment_op ".=" if {![string length $rhs]} { set segment_first_word [lindex $segment_members 1] @@ -1901,7 +2490,7 @@ namespace eval punk { set segment_first_word $rhs set segment_second_word [lindex $segment_members 1] } - } elseif {[regexp $punk::re_assign $possible_assignment _ returnvarspec rhs]} { + } elseif {[regexp $re_assign $possible_assignment _ returnvarspec rhs]} { set segment_op "=" #never scripts set segment_first_word [lindex $segment_members 1] @@ -1928,7 +2517,7 @@ namespace eval punk { #set forward_result $segment_result set previous_result $segment_result } else { - #debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a+]} 4 + debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a+]} 4 set more_pipe_segments 0 } @@ -1966,6 +2555,8 @@ namespace eval punk { know {[lindex $args 0 0] eq "exitcode"} { uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] } + + #----------------------------- # # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. @@ -1987,33 +2578,36 @@ namespace eval punk { #if {[info proc ::punk::_unknown] eq ""} {rename unknown ::punk::_unknown} + + proc ::punk::_unknown_assign_dispatch {partzerozero varspecs rhs arglist} { + set tail [lassign $args hd] + if {$hd ne $partzerozero} { + regexp $punk::re_assign $hd _ varspecs rhs + } + tailcall ::punk::match_assign $varspecs $rhs $tail + } + #variable re_assign {^([^\r\n=\{]*)=(.*)} - know {[regexp $punk::re_assign [lindex $args 0 0] _ varspecs rhs]} { - if {![string length $varspecs]} { + 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" - } + #} #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 - if {[lindex $args 0] ne [lindex $args 0 0]} { - regexp $punk::re_assign [lindex $args 0] _ varspecs rhs + set tail [lassign $args hd] + if {$hd ne $partzerozero} { + regexp $punk::re_assign $hd _ varspecs rhs } - set tail [lrange $args 1 end] #must be tailcall so match_assign runs at same level as the unknown proc tailcall ::punk::match_assign $varspecs $rhs $tail } - #.= 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]] - } #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]} { if {![string length [string trim $val2]]} { if {[llength $args] > 1} { @@ -2044,6 +2638,22 @@ namespace eval punk { } } } + #.= 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]} { + 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]] + } #know {[regexp {^=([^=]*)} [lindex $args 0] _ v1]} { # set calc [concat $v1 [lrange $args 1 end]] # puts stderr "= $calc" @@ -2053,13 +2663,43 @@ namespace eval punk { } configure_unknown #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. - proc pipematch {args} { + # + + #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc + #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. + proc % {args} { + set arglist [lassign $args assign] ;#tail, head + if {$assign eq ".="} { + set cmdlist [list ::punk::match_exec "" "" {*}$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] + } else { + error "pipesyntax punk::% unable to interpret pipeline '$args'" + } + } else { + set cmdlist [list ::punk::match_exec "" "" {*}$args] + } + tailcall {*}$cmdlist + } + + proc ispipematch {args} { + expr {[lindex [uplevel 1 [list pipematch {*}$args]] 0] eq "ok"} + } + + #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} + proc pipematch {args} { #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 variable re_dot_assign variable re_assign - set assign [lindex $args 0] - set arglist [lrange $args 1 end] + set arglist [lassign $args assign] if {$assign eq ".="} { set cmdlist [list ::punk::match_exec "" "" {*}$arglist] } elseif {$assign eq "="} { @@ -2072,14 +2712,23 @@ namespace eval punk { set cmdlist $args #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] } - if {[catch {uplevel 1 $cmdlist} result]} { - debug.punk.pipe {pipematch error $result} 4 - return [dict create error [dict create reason $result]] + #debug.punk.pipe {pipematch error $result} 4 + 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 [list error [list mismatch $result]] + } + if {[string match "pipesyntax*" $result]} { + error $result + } + #return [dict create error [dict create reason $result]] + return [list error [list reason $result]] } else { - debug.punk.pipe {pipematch result $result } 4 - return [dict create ok [dict create result $result]] + #debug.punk.pipe {pipematch result $result } 4 + #return [dict create ok [dict create result $result]] + return [list ok [list result $result]] } } @@ -2116,11 +2765,20 @@ namespace eval punk { upvar 1 $varname nomatchvar if {[catch {uplevel 1 $cmdlist} result]} { debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a+]} 3 + if {[string match "pipesyntax*" $result]} { + set errordict [dict create error [dict create pipesyntax $result]] + set nomatchvar $errordict + error $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 + error $result + } set errordict [dict create error [dict create reason $result]] - #uplevel 1 [list set $varname $errordict] set nomatchvar $errordict #re-raise the error for pipeswitch to deal with - #uplevel 1 [list error $result] error $result } else { debug.punk.pipe {pipematchnomatch result $result } 4 @@ -2131,24 +2789,27 @@ namespace eval punk { #return [dict create ok [dict create result $result]] } } + + #should only raise an error for pipe syntax errors - all other errors should be wrapped proc pipecase {args} { #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 - variable re_dot_assign - variable re_assign - - set assign [lindex $args 0] - set arglist [lrange $args 1 end] + set arglist [lassign $args assign] if {$assign eq ".="} { set cmdlist [list ::punk::match_exec "" "" {*}$arglist] } elseif {$assign eq "="} { set cmdlist [list ::punk::match_assign "" "" $arglist] - } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::match_exec $returnvarspecs $rhs {*}$arglist] - } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::match_assign $returnvarspecs $rhs $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] + } else { + error "pipesyntax punk::% unable to interpret pipeline '$args'" + } } else { - set cmdlist $args - #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] + set cmdlist [list ::punk::match_exec "" "" {*}$args] } @@ -2158,22 +2819,48 @@ namespace eval punk { error $result } if {[string match "binding*mismatch*" $result]} { - return [dict create error [dict create reason $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]] + } + #we can't always treat $result as a list - may be malformed + if {[catch {lindex $result 0} word1]} { + tailcall error $result + } else { + if {$word1 in [list "switcherror" "funerror"]} { + error $result "pipecase [lsearch -all -inline $args "*="]" + } + if {$word1 in [list "resultswitcherror" "resultfunerror"]} { + #recast the error as a result without @@ok wrapping + #use the tailcall return to stop processing other cases in the switch! + tailcall return [dict create error $result] + } + if {$word1 eq "ignore"} { + #suppress error, but use normal return + return [dict create error [dict create suppressed $result]] + } else { + #normal tcl error + #return [dict create error [dict create reason $result]] + tailcall error $result + } } - error $result } else { tailcall return [dict create ok [dict create result $result]] } } + #note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. + #It also - somewhat unusually accepts args - which we provide as 'switchargs' + #This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. + #Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. proc pipeswitch {pipescript args} { - set nextargs $args - unset args - upvar args upargs - set upargs $nextargs - #set prefix "set args \[list $args\]\n" - #set pipescript $prefix$pipescript + #set nextargs $args + #unset args + #upvar args upargs + #set upargs $nextargs + upvar switchargs switchargs + set switchargs $args uplevel 1 [list if 1 $pipescript] } proc ansi+ {args} { @@ -2244,9 +2931,22 @@ namespace eval punk { } } proc winpath {path} { + #NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) + #This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. + #e.g there is potential confusion when there is a c folder on c: drive (c:/c) + #I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt + #whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. + #I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. + #It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists + #This makes it hard to use things like 'file normalize' - which also looks at things like current volume. + # + #Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep + #which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. + #The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common + # #convert /c/etc to C:/etc - set re {^/([[:alpha:]]){1}/.*} - + set re_slash_x_slash {^/([[:alpha:]]){1}/.*} + set re_slash_else {^/([[:alpha:]]*)(.*)} set volumes [file volumes] #exclude things like //zipfs:/ set driveletters [list] @@ -2256,20 +2956,36 @@ namespace eval punk { } } #puts stderr "->$driveletters" - if {[regexp $re $path _ letter]} { + if {[regexp $re_slash_x_slash $path _ letter]} { #upper case appears to be windows canonical form - if {[string toupper $letter] in $driveletters} { - set path [string toupper $letter]:/[string range $path 3 end] - } + set path [string toupper $letter]:/[string range $path 3 end] } elseif {[regexp {^/mnt|MNT/([[:alpha:]]){1}/.*} $path _ letter]} { - if {[string toupper $letter] in $driveletters} { - set path [string toupper $letter]:/[string range $path 7 end] - } + set path [string toupper $letter]:/[string range $path 7 end] + } elseif {[regexp $re_slash_else $path _ firstpart remainder]} { + #could be for example /c or /something/users + if {[string length $firstpart] == 1} { + set letter $firstpart + set path [string toupper $letter]:/ + } else { + #attempt to use cygpath helper + if {![catch { + set cygpath [runout -n cygpath -w $path] ;#! + set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display + } errM]} { + set path [string map [list "\\" "/"] $cygpath] + } else { + error "Path '$path' does not appear to be in a standard form. For unix-like paths on windows such as /x, x must correspond to a drive letter. Consider installing cygwin's cygpath tool to see if that helps." + } + } } #puts stderr "=> $path" #things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder + # + #By now file normalize shouldn't do too many shannanigans related to cwd.. + #We want it to look at cwd for relative paths.. but we don't consider things like /c/Users to be relative even on windows if {![file exists [file dirname $path]]} { set path [file normalize $path] + #may still not exist.. that's ok. } return $path } @@ -2461,6 +3177,53 @@ namespace eval punk { namespace export help aliases alias cdwin cdwindir winpath windir app namespace ensemble create + #todo - in thread + #todo - streaming version + proc dirfiles_lists {{glob ""}} { + set dir [pwd] + if {$glob eq ""} { + set glob "*" + } + set dirname [file dirname $glob] ;# for * or something* will return just "." which is ok + set ftail [file tail $glob] + + if {[string first ? $glob] >= 0 || [string first * $glob] >=0} { + #has globchar (we only recognise in tail) + set location $dirname + set glob $ftail + } else { + set location $dirname/$ftail + set glob * + } + + set dirs [glob -nocomplain -directory $location -type d -tail $glob] + set files [glob -nocomplain -directory $location -type f -tail $glob] + return [list dirs $dirs files $files] + } + proc dirfiles {{glob ""}} { + + package require overtype + set contents [dirfiles_lists $glob] + set dirs [dict get $contents dirs] + set files [dict get $contents files] + + set widest 4 + foreach d $dirs { + set w [string length $d] + if {$w > $widest} { + set widest $w + } + } + + set displaylist [list] + set col1 [string repeat " " [expr {$widest + 2}]] + foreach d $dirs f $files { + lappend displaylist [overtype::left $col1 $d]$f + } + + return [list_as_lines $displaylist] + } + #tailcall is important #TODO - fix. conflicts with Tk toplevel command "." proc ./ {args} { @@ -2472,7 +3235,10 @@ namespace eval punk { if {![llength $args]} { - set out [runout -n ls -aFC] + #ls is too slow even over a fairly low-latency network + #set out [runout -n ls -aFC] + set out [punk::dirfiles] + #puts stdout $out #puts stderr [a+ white]$out[a+] set result [pwd] @@ -2485,18 +3251,39 @@ namespace eval punk { } return $result } else { - set a1 [lindex $args 0] + #set a1 [lindex $args 0] + set atail [lassign $args a1] if {$a1 in [list . .. "./" "../"]} { if {$a1 in [list ".." "../"]} { cd $a1 } - tailcall punk::./ {*}[lrange $args 1 end] + tailcall punk::./ {*}$atail } + set curdir [pwd] - set path $curdir/$a1 + set ptype [file pathtype $a1] + if {$ptype eq "absolute"} { + set path $a1 + } elseif {$ptype eq "volumerelative"} { + if {$::tcl_platform(platform) eq "windows"} { + #unix looking paths like /c/users or /usr/local/etc are reported by tcl as volumerelative.. (as opposed to absolute on unix platforms) + if {[string index $a1 0] eq "/"} { + set path [punk::winpath $a1] + #puts stderr "winpath: $path" + } else { + set path $curdir/$a1 + } + } else { + # unknown what paths are reported as this on other platforms.. treat as absolute for now + set path $a1 + } + } else { + set path $curdir/$a1 + } + if {[file type $path] eq "file"} { if {[string tolower [file extension $path]] in [list ".tcl" ".tm"]} { - set newargs [lrange $args 1 end] + set newargs $atail set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -2508,7 +3295,7 @@ namespace eval punk { } if {[file type $path] eq "directory"} { cd $path - tailcall punk::./ {*}[lrange $args 1 end] + tailcall punk::./ {*}$atail } error "Cannot access path $path" } @@ -2521,7 +3308,8 @@ namespace eval punk { set path ../[file join {*}$args] } cd $path - set out [runout -n ls -aFC] + #set out [runout -n ls -aFC] + set out [punk::dirfiles] set result [pwd] #return $out\n[pwd] set chunklist [list] @@ -2533,6 +3321,10 @@ namespace eval punk { } return $result } + proc list_as_lines {list {joinchar \n}} { + join $list $joinchar + } + proc ls {args} { if {![llength $args]} { set args [list [pwd]] @@ -2552,7 +3344,7 @@ namespace eval punk { proc cdwin {path} { set path [punk::winpath $path] if {$::repl::running} { - repl::term::term::set_console_title $path + repl::term::set_console_title $path } cd $path } @@ -2843,26 +3635,52 @@ namespace eval punk { interp alias {} linedict {} punk::linedict interp alias {} dictline {} punk::dictline + interp alias {} % {} punk::% interp alias {} pipeswitch {} punk::pipeswitch interp alias {} pipecase {} punk::pipecase interp alias {} pipematch {} punk::pipematch + interp alias {} ispipematch {} punk::ispipematch interp alias {} pipenomatchvar {} punk::pipenomatchvar + interp alias {} nscommands {} ,'ok@0.= { + upvar caseresult caseresult + if {![info exists ns]} { + set ns "" + } + pipeswitch { + #no glob chars present + pipecase \ + caseresult.= val $ns |input> \ + 1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> { + uplevel #0 [list info commands ${input}::*] + } + + #pipecase1 ns has one or more of glob chars * or ? + pipecase \ + caseresult.= val $ns |input> { + uplevel #0 [list info commands ${input}] + } + } + } |data@@ok/result> {set data} |> {lmap v $data {namespace tail $v}} |> lsort |> {join $data \n} pattern .. Create >f @@ -2884,10 +3702,27 @@ namespace eval punk { return 0 return $v } - >f .. Method add_llength {total listval} { + >f .. Method list_map {commandlist list} { + tailcall lmap item $list $commandlist + } + >f .. Method list_unique {args} { + set list [concat {*}$args] + set d [dict create] + foreach item $list { + dict set d $item "" + } + dict keys $d + } + >f .. Method list_as_lines {args} { + set list [concat {*}$args] + join $list \n + } + >f .. Method list_filter_expr {} {} + + >f .. Method sum_llength {total listval} { expr {$total + [llength $listval]} } - >f .. Method add_length {total stringval} { + >f .. Method sum_length {total stringval} { expr {$total + [string length $stringval]} } >f .. Method debug {total item} { @@ -2895,12 +3730,25 @@ namespace eval punk { expr {$total + 1} } >f .. Method dict_walk {d key} { - dict get $d key + dict get $d $key } >f .. Method sum {total num} { expr {$total + $num} } - + + interp alias {} >f {} punk::>f + + #Pattern-matching based functional operations + >pattern .. Create >P + >P .. Method map {pattern commandlist sequence} { + #set segment [string map [list $commandlist] {}] + + set pipeline [list % {val $item} "|,item,$pattern>" $commandlist {lmap val $l {{*}$p $val }} + } + + + #example of aliasing a punk pipeline interp alias {} _commands {} .=info commands punk::%glob% |> .=lmap v %data% {namespace tail $v}