punkshell/scriptlib/tests/fun.tcl

#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