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.

401 lines
13 KiB

#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 casenomatch [string map [list <name> $name] {pipecase .= {error "casenomatch fun: <name> args: $args" "pipefun::fun <name>" {casenomatch unhandled_args}} <args|}]
append casenomatch { {*}$switchargs}
append pipecases $casenomatch\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' (argspec:$argspec)"
#interp alias {} $name {} pipeswitchc $pipecases
interp alias {} $name {} pipeswitch $pipecases
}
interp alias {} fun {} [nsjoin [namespace current] pipefun::fun]
interp alias {} funs {} [nsjoin [namespace current] pipefun::funs]
interp alias {} funclear {} [nsjoin [namespace current] pipefun::funclear]
interp alias {} funinfo {} [nsjoin [namespace current] pipefun::funinfo]
interp alias {} funclause {} [nsjoin [namespace current] 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 stderr "You're $a! $m"
pipeswitch {
pipecase r@@ok/result.= age $a
pipecase r.= age $a
}
return $r
}
#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@@casemismatch.= 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