You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
393 lines
13 KiB
393 lines
13 KiB
2 years ago
|
|
||
|
|
#slow - but basically works. Needs pipeline compilation to tcl script to speed up? funcl?
|
||
|
|
package require punk
|
||
|
|
|
||
|
|
|
||
|
|
#todo - pinned vars.. what scope? add a facility to bake values into proc body? (what equivalent is there for pipelines not bound to a proc scope? apply?)
|
||
|
|
#if a fun is intended to bind in the caller's scope - then we just need a way to return the fun contents as a runnable pipeline
|
||
|
|
# - conflict between build-time and run-time pinned vars? Is this really 2 separate concepts?
|
||
|
|
# - using a pin to help build up the pattern vs using the pin for pipelined/context data?
|
||
|
|
# - unpinned vars are clearly required in the implementation bodies - which is 'pipeline' scope only.. and limited to the running clause.
|
||
|
|
#pipefun::setvar ?
|
||
|
|
#consider oo version that uses properties of the object as the pinned vars in the pattern-spec?
|
||
|
|
#pinned vars are important to be able to pass more complex values than are allowed by the pattern mini-lang e.g paths /etc (or is that a misuse???)
|
||
|
|
|
||
|
|
#what does a pin on the argspec <^var| even mean? other vars in <| are pure pipeline scope
|
||
|
|
# pins in intermediate pipes.. e.g |^somevar@1> could be used as sanity checks for pipeline-scope vars.. but is there a real need/usecase?
|
||
|
|
|
||
|
|
|
||
|
|
namespace eval pipefun {
|
||
|
|
variable funs [dict create]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#note this isn't a 'standard' closure in the sense that the captured vars aren't modifiable - a coro or object could be used to hold state if that is required.
|
||
|
|
proc pipefun::closure0 {body} {
|
||
|
|
set binding {}
|
||
|
|
foreach v [uplevel 1 info locals] {
|
||
|
|
upvar 1 $v var
|
||
|
|
if {[info exists var]} {
|
||
|
|
lappend binding [list $v $var] ;#values captured as defaults for apply args.
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return [list apply [list $binding $body [uplevel 1 namespace current]]]
|
||
|
|
}
|
||
|
|
|
||
|
|
#much slower attempting to upvar all at once with different varnames
|
||
|
|
proc pipefun::closure1 {body} {
|
||
|
|
set binding {}
|
||
|
|
if {[info level] == 1} {
|
||
|
|
#up 1 is global
|
||
|
|
set get_vars [list info vars]
|
||
|
|
} else {
|
||
|
|
set get_vars [list info locals]
|
||
|
|
}
|
||
|
|
set upinfo [uplevel 1 "list \[{*}$get_vars\] \[namespace current\]"]
|
||
|
|
lassign $upinfo vars ns
|
||
|
|
#puts stdout ">>> got vars:$vars ns:$ns"
|
||
|
|
|
||
|
|
set pairs [lmap v $vars i [lsearch -all $vars *] {list $v v$i}]
|
||
|
|
set flatpairs [concat {*}$pairs]
|
||
|
|
upvar 1 {*}$flatpairs
|
||
|
|
#puts stdout ">>> $flatpairs"
|
||
|
|
foreach {v vi} $flatpairs {
|
||
|
|
if {![array exists $vi] && [info exists $vi]} {
|
||
|
|
lappend binding [list $v [set $vi]] ;#values captured as defaults for apply args.
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return [list apply [list $binding $body $ns]]
|
||
|
|
}
|
||
|
|
proc pipefun::closure1 {body} {
|
||
|
|
set binding {}
|
||
|
|
if {[info level] == 1} {
|
||
|
|
#up 1 is global
|
||
|
|
set get_vars [list info vars]
|
||
|
|
} else {
|
||
|
|
set get_vars [list info locals]
|
||
|
|
}
|
||
|
|
set upinfo [uplevel 1 "list \[{*}$get_vars\] \[namespace current\]"]
|
||
|
|
lassign $upinfo vars ns
|
||
|
|
#puts stdout ">>> got vars:$vars ns:$ns"
|
||
|
|
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.
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return [list apply [list $binding $body $ns]]
|
||
|
|
}
|
||
|
|
proc pipefun::closure {body} {
|
||
|
|
set binding {}
|
||
|
|
if {[info level] == 1} {
|
||
|
|
#up 1 is global
|
||
|
|
set get_vars [list info vars]
|
||
|
|
} else {
|
||
|
|
set get_vars [list info locals]
|
||
|
|
}
|
||
|
|
#set upinfo [uplevel 1 "list \[{*}$get_vars\] \[namespace current\]"]
|
||
|
|
#lassign $upinfo vars ns
|
||
|
|
#puts stdout ">>> got vars:$vars ns:$ns"
|
||
|
|
foreach v [uplevel 1 {*}$get_vars] {
|
||
|
|
upvar 1 $v var
|
||
|
|
if {(![array exists var]) && [info exists var]} {
|
||
|
|
lappend binding [list $v $var] ;#values captured as defaults for apply args.
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return [list apply [list $binding $body [uplevel 1 namespace current]]]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc pipefun::funs {{glob *}} {
|
||
|
|
variable funs
|
||
|
|
return [dict keys $funs $glob]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc pipefun::testpattern {pattern val} {
|
||
|
|
set d [apply {{mv res} {
|
||
|
|
punk::_multi_bind_result $mv $res -levelup 1
|
||
|
|
}} $pattern $val]
|
||
|
|
#set r [_handle_bind_result $d]
|
||
|
|
#set pipedvars [dict get $d setvars]
|
||
|
|
return $d
|
||
|
|
}
|
||
|
|
|
||
|
|
proc pipefun::funclear {nameglob} {
|
||
|
|
variable funs
|
||
|
|
foreach k [dict keys $funs $nameglob] {
|
||
|
|
dict unset funs $k
|
||
|
|
}
|
||
|
|
}
|
||
|
|
proc pipefun::funinfo {name} {
|
||
|
|
package require overtype
|
||
|
|
variable funs
|
||
|
|
set keys [dict keys [dict get $funs $name defs]]
|
||
|
|
set out "fun: $name\n"
|
||
|
|
append out "clause_count: [llength $keys]\n"
|
||
|
|
#append out [punk::list_as_lines $keys]
|
||
|
|
set maxwidth [expr {[string length Pattern] + 2}]
|
||
|
|
foreach k $keys {
|
||
|
|
set w [string length $k]
|
||
|
|
if {$w > $maxwidth} {
|
||
|
|
set maxwidth $w
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set col1 [string repeat " " [expr {$maxwidth + 2}]]
|
||
|
|
set linewidth [expr {[string length $col1] + 1 + [string length LineCount]}]
|
||
|
|
set dashes [string repeat - $linewidth]
|
||
|
|
append out $dashes\n
|
||
|
|
append out "[overtype::left $col1 Pattern] LineCount\n"
|
||
|
|
append out $dashes\n
|
||
|
|
foreach k $keys {
|
||
|
|
set body [dict get $funs $name defs $k]
|
||
|
|
set linecount [llength [split $body \n]]
|
||
|
|
append out "[overtype::left $col1 $k] [$linecount]\n"
|
||
|
|
}
|
||
|
|
append out $dashes\n
|
||
|
|
return $out
|
||
|
|
}
|
||
|
|
proc pipefun::funclause {name match args} {
|
||
|
|
variable funs
|
||
|
|
set defaults [list -delete 0 -active 1]
|
||
|
|
if {([llength $args] % 2) != 0} {
|
||
|
|
error "funclause options must be in pairs. Known options: [dict keys $defaults]"
|
||
|
|
}
|
||
|
|
set opts [dict merge $defaults $args]
|
||
|
|
|
||
|
|
if {[dict exists $funs $name defs $match]} {
|
||
|
|
set body [dict get $funs $name defs $match]
|
||
|
|
if {[dict get $opts -delete]} {
|
||
|
|
dict unset funs $name defs $match
|
||
|
|
}
|
||
|
|
|
||
|
|
return $body
|
||
|
|
} else {
|
||
|
|
return "no clause '$match'"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#todo - examine arity of call and limit cases tested?
|
||
|
|
proc pipefun::fun_proc {name argspec body} {
|
||
|
|
variable funs
|
||
|
|
|
||
|
|
if {[dict exists $funs $name]} {
|
||
|
|
set definitions [dict get $funs $name defs]
|
||
|
|
dict set definitions $argspec $body ;#add or override
|
||
|
|
dict set funs $name defs $definitions ;#write-back
|
||
|
|
} else {
|
||
|
|
#first implementations
|
||
|
|
dict set funs $name defs [dict create $argspec $body]
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[llength [info commands $name]]} {
|
||
|
|
if {[catch {info body $name} body1]} {
|
||
|
|
error "fun: unable to update function '$name' - not a proc"
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set body1 ""
|
||
|
|
}
|
||
|
|
|
||
|
|
#what is the point of <argspec> at beginning?
|
||
|
|
set test_case_template {
|
||
|
|
pipecase <argspec>.= list {*}$arglist |args> {
|
||
|
|
<body>
|
||
|
|
} <<argspec>| {*}$arglist
|
||
|
|
}
|
||
|
|
set case_template1 {
|
||
|
|
pipecase .= list {*}$arglist |args> {
|
||
|
|
<body>
|
||
|
|
} <<argspec>| {*}$arglist
|
||
|
|
}
|
||
|
|
set case_template {
|
||
|
|
pipecase .= {
|
||
|
|
<body>
|
||
|
|
} <<argspec>| {*}$switchargs
|
||
|
|
}
|
||
|
|
|
||
|
|
set pipecases ""
|
||
|
|
|
||
|
|
set definitions [dict get $funs $name defs]
|
||
|
|
dict for {a b} $definitions {
|
||
|
|
set impl [string map [list <argspec> $a <body> $b] $case_template]
|
||
|
|
append pipecases ${impl}
|
||
|
|
}
|
||
|
|
set nsup [uplevel 1 [list namespace current]]
|
||
|
|
if {$nsup eq "::"} {
|
||
|
|
set nsup ""
|
||
|
|
}
|
||
|
|
if {![string match "::*" $name]} {
|
||
|
|
set name "${nsup}::$name"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc $name args [string map [list <pipecases> $pipecases] {
|
||
|
|
pipeswitchc {
|
||
|
|
<pipecases>
|
||
|
|
} $args
|
||
|
|
}]
|
||
|
|
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
proc pipefun::fun {name argspec body} {
|
||
|
|
variable funs
|
||
|
|
if {[dict exists $funs $name]} {
|
||
|
|
set definitions [dict get $funs $name defs]
|
||
|
|
dict set definitions $argspec $body ;#add or override
|
||
|
|
dict set funs $name defs $definitions ;#write-back
|
||
|
|
} else {
|
||
|
|
#first implementations
|
||
|
|
dict set funs $name defs [dict create $argspec $body]
|
||
|
|
}
|
||
|
|
if {[llength [info commands $name]]} {
|
||
|
|
if {![llength [interp alias "" $name]]} {
|
||
|
|
error "fun: unable to update function '$name' - not an alias"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
set pipecases ""
|
||
|
|
set definitions [dict get $funs $name defs]
|
||
|
|
dict for {a b} $definitions {
|
||
|
|
#set impl [string map [list <argspec> $a <body> $b] $case_template]
|
||
|
|
#append pipecases ${impl}
|
||
|
|
|
||
|
|
set case [list pipecase .= $b <$a|]
|
||
|
|
|
||
|
|
#set case [list pipecase ,$a= |$a> .= $b <|]
|
||
|
|
|
||
|
|
|
||
|
|
append case { {*}$switchargs}
|
||
|
|
#we can't maintain case as a proper list.. because it isn't. (contains {*}$xxx)
|
||
|
|
append pipecases $case\n
|
||
|
|
}
|
||
|
|
set nsup [uplevel 1 [list namespace current]]
|
||
|
|
if {$nsup eq "::"} {
|
||
|
|
set nsup ""
|
||
|
|
}
|
||
|
|
#if {![string match "::*" $name]} {
|
||
|
|
# set name "${nsup}::$name"
|
||
|
|
#}
|
||
|
|
|
||
|
|
#proc $name args [string map [list <pipecases> $pipecases] {
|
||
|
|
# % .= {
|
||
|
|
# pipeswitch {
|
||
|
|
# <pipecases>
|
||
|
|
# }
|
||
|
|
# } <arglist| {*}$args
|
||
|
|
#}]
|
||
|
|
puts "creating alias '$name'"
|
||
|
|
interp alias {} $name {} pipeswitchc $pipecases
|
||
|
|
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
interp alias {} fun {} pipefun::fun
|
||
|
|
interp alias {} funs {} pipefun::funs
|
||
|
|
interp alias {} funclear {} pipefun::funclear
|
||
|
|
interp alias {} funinfo {} pipefun::funinfo
|
||
|
|
interp alias {} funclause {} pipefun::funclause
|
||
|
|
|
||
|
|
fun age argc#,v@0-end {
|
||
|
|
#always runs for age - falls through to other implementations
|
||
|
|
puts "age called with argc:$argc args:$v"
|
||
|
|
error [list ignore]
|
||
|
|
}
|
||
|
|
|
||
|
|
#only runs for exactly 2 args
|
||
|
|
fun age a@,m@,2# {
|
||
|
|
puts "You're $a! $m"
|
||
|
|
# pipematch r@@ok/resultx.= age $a
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#experiment with match but return error instead of ok {result xxx}
|
||
|
|
fun age a {
|
||
|
|
% switchresult.= pipeswitch {
|
||
|
|
#puts "testing-arguments: $a"
|
||
|
|
if {![info exists a]} {
|
||
|
|
error [list ignore no-arg]
|
||
|
|
}
|
||
|
|
pipecase .= val $a |a@0> \
|
||
|
|
0.= {
|
||
|
|
string is integer -strict $a
|
||
|
|
} |> {
|
||
|
|
puts stderr "age must be an integer"
|
||
|
|
val " bad arg '$a' - must be an integer"
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
#puts stdout ">>> $switchresult"
|
||
|
|
% status@@/@0.= val $switchresult
|
||
|
|
% contents@1.= val $switchresult
|
||
|
|
puts stdout ">>> $switchresult"
|
||
|
|
|
||
|
|
#an ordinary return value (extracted from @@ok/result above) will get wrapped in 'ok {result <value>}' which can be confusing if the result is supposed to indicate a fault
|
||
|
|
#return $status
|
||
|
|
#even worse if we return switchresult as we would get a double @@ok/result
|
||
|
|
|
||
|
|
#pipeswitch can return @@ok/result or @@error
|
||
|
|
# we could use something like:
|
||
|
|
#if {[$status eq "error"]} {...}
|
||
|
|
# or
|
||
|
|
#if {$status eq "ok"} {...}
|
||
|
|
# or just use error "switcherror ..." directly in the above pipecase, which would propagate through as an error
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
#wrapping in own error-bag doesn't really help as the outer ok wrapping will still get applied
|
||
|
|
#return [list error {reason "bad arg"}]
|
||
|
|
|
||
|
|
#raising a normal error in the above pipeswitch or anywhere in the fun results in an @@error/reason *return value*
|
||
|
|
#(as opposed to an @@error/mismatch *return value* for a failed binding)
|
||
|
|
#i.e later implementations will still be run as this will still just be a non-match
|
||
|
|
#error "$contents"
|
||
|
|
|
||
|
|
|
||
|
|
#will work to raise an error, but bad form to fake a pipesyntax error
|
||
|
|
#error "pipesyntax bad-arg"
|
||
|
|
|
||
|
|
#to cause pipewitch above this to raise an error and stop processing cases..
|
||
|
|
#use 'switcherror' or 'funerror' as first element of a list e.g
|
||
|
|
#error [list funerror [list reason "$contents"]]
|
||
|
|
|
||
|
|
#attempting to raise a normal error in the above switch - but then a bad match here.. will only cause this implementation to be a non-match
|
||
|
|
# and so other implementations will still be run
|
||
|
|
#return [@@ok/result.= val $switchresult]
|
||
|
|
|
||
|
|
#in this example - we want to force a terminal error (see switcherror above) or a terminal *result* that isn't wrapped in 'ok',
|
||
|
|
#but only if we *don't* have a mismatch.
|
||
|
|
#i.e we require an @@error/mismatch to proceed to other implementations
|
||
|
|
#puts stderr "=--->$switchresult"
|
||
|
|
if {[ispipematch r@@error/mismatch.= val $switchresult]} {
|
||
|
|
#all good - simulate an @@error/mismatch - or raise an 'ignore' error so that this implementation is considered to be unmatched and we fall through to others.
|
||
|
|
#puts stdout "=ispipematch true"
|
||
|
|
error [list ignore [list argcheck passed]]
|
||
|
|
#error "binding mismatch"
|
||
|
|
} else {
|
||
|
|
#puts stdout "=ispipematch false"
|
||
|
|
#error [list resultfunerror $contents]
|
||
|
|
error [list funerror $contents]
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
fun age 1 {puts "welcome!"}
|
||
|
|
fun age 18 {puts "yay!"}
|
||
|
|
fun age 42 {
|
||
|
|
error "Test that error is raised."
|
||
|
|
}
|
||
|
|
fun age ''/0 {puts "enter an age, and optionally a message";return "no-value-supplied"}
|
||
|
|
fun age a,100 {puts "congrats!"; return "congrats-$a"}
|
||
|
|
fun age b {puts "cool"; return "cool-$b"}
|
||
|
|
#fun age a,3+/# {puts stderr "too many args"; return}
|
||
|
|
|
||
|
|
age 100
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|