punkshell/scriptlib/tests/fn.tcl

package provide funcl [namespace eval funcl {
    variable version
    set version 0.1
}]
#funcl = function list  (nested call structure)
#
#a basic functional composition o combinator
#o(f,g)(x) == f(g(x))

namespace eval funcl {

    #from punk
    proc arg_is_script_shaped {arg} {
            if {[string first " " $arg] >= 0} {
                return 1
            } elseif {[string first \n $arg] >= 0} {
                return 1
            } elseif {[string first ";" $arg] >= 0} {
                return 1
            } elseif {[string first \t $arg] >= 0} {
                return 1
            } else {
                return 0
            }
    }


    proc o args {
        set   closing [string repeat {]} [expr [llength $args]-1]]
        set   body   "[join $args { [}] \$data $closing"
        return $body
    }

    proc o_ args {
        set body ""
        set tails [lrepeat [llength $args] ""]
        puts stdout "tails: $tails"
        
        set end [lindex $args end]
        if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
            set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}]
        } else {
            set endfunc $end
        }
        if {[llength $args] == 1} {
            return $endfunc
        }
        
        set wrap { [}
        append wrap $endfunc
        append wrap { ]}
        
        set i 0
        foreach cmdlist [lrange $args 0 end-1] {
            set is_script 0
            if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
                set is_script 1
                set script [lindex $cmdlist 0]
            }
            set t ""
            if {$i > 0} {
                append body { [}
            }
            set posn [lsearch $cmdlist _]
            if {$posn <= 0} {
                append body $cmdlist
                if {$i == [expr {[llength $args] -2}]} {
                    #append body " \$data"
                    append body " $wrap"
                }
                if {$i > 0} {
                    set t {]}
                }
            } else {
                append body [lrange $cmdlist 0 $posn-1]
                if {$i == [expr {[llength $args] -2}]} {
                    #append body " \$data"
                    append body " $wrap"
                }
                set t [lrange $cmdlist $posn+1 end]
                if {$i > 0} {
                    append t { ]}
                }
            }
            lset tails $i $t
            incr i
        }
        append body [join [lreverse $tails] " "]
        puts stdout "tails: $tails"
        
        return $body
     }

    #review -  consider _call -- if count > 1 then they must all be callable cmdlists(?) 
    # what does it mean to have additional _fn wrapper with no other elements? (no actual function)
    #e.g  _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}}
    # what type indicates running subtrees in parallel vs sequentially?
    # any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc.
    #
    #
    # accept or return a funcl (or funcltree if multiple funcls in one commandlist)
    # also accept/return a call -  return empty list if passed a call
    proc next_funcl {funcl_or_tree} {
        if {[lindex $funcl_or_tree 0] eq "_call"} {
            return [list]
        }
        if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} {
            set funcl $funcl_or_tree
        } else {
            error "funcltree not implemented"
        }


        set count [lindex $funcl 1]
        if {$count == 0} {
            #null funcl.. what is it? metadata/placeholder?
            return $funcl
        }
        set indices [lrange $funcl 2 [expr {1 + $count}]]
        set i 0
        foreach idx $indices {
            if {$i > 0} {
                #todo - return a funcltree 
                error "multi funcl not implemented"
            }
            set next [lindex $funcl $idx]
            incr i
        }
        
        return $next

    }
    
    #convert a funcl to a tcl script
    proc funcl_script {funcl} {
        if {![llength $funcl]} {
            return ""
        }
        set body ""
        set tails [list]
        
        set type [lindex $funcl 0]
        if {$type ni [list "_fn" "_call"]} {
            #todo - handle funcltree 
            error "type $type not implemented"
        }
        
        
        #only count of 1 with index 3 supported(?)
        if {$type eq "_call"} {
            #leaf
            set cmdlist [lindex $funcl 3]
            return $cmdlist
        }
        
        #we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times.
        #by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?)
        # we would still need to maintain state to stitch it back together once returned from a subtree..
        # ie multiple tail parts
        set count [lindex $funcl 1]
        
        if {$count == 1} {
            set idx [lindex $funcl 2]
            if {$idx == 3} {
                set cmdlist_pre [list]
            } else {
                set cmdlist_pre [lrange $funcl 3 $idx-1]
            }
            append body $cmdlist_pre
            set t [lrange $funcl $idx+1 end]
            lappend tails $t
        } else {
            #?? 
            error "funcl_script branching not yet supported"
        }
        
        
        set get_next 1
        set i 1
        while {$get_next} {
            set funcl [next_funcl $funcl]
            if {![llength $funcl]} {
                set get_next 0
            }
            lassign $funcl type count idx ;#todo support count > 1
            if {$type eq "_call"} {
                set get_next 0
            }
            set t ""
            if {$type eq "_call"} {
                append body { [}
                append body [lindex $funcl $idx]
                append body { ]}
            } else {
                append body { [}
                if {$idx == 3} {
                    set cmdlist_pre [list]
                } else {
                    set cmdlist_pre [lrange $funcl 3 $idx-1]
                }
                append body $cmdlist_pre
                set t [lrange $funcl $idx+1 end]
                lappend tails $t
                lappend tails { ]}
            }
            incr i
        }
        append body [join [lreverse $tails] " "]
        #puts stdout "tails: $tails"
        
        return $body
    }


    interp alias "" o_of "" o_of_n 1

    #o_of_n
    #tcl list rep o combinator
    #
    #  can take lists of ordinary commandlists, scripts and funcls
    # _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg)
    # _fn 0 indicates next item is an unwrapped commandlist (terminal command)
    #
    #o_of is equivalent to o_of_n 1   (1 argument o combinator)
    #last n args are passed to the prior function 
    #e.g  for n=1  f a b =  f(a(b))
    #e.g for n=2, e f a b =  e(f(a b))
    proc o_of_n {n args} {
        if {$n != 1} {
            error "o_of_n only implemented for 1 sub-funcl"
        }
        set comp [list] ;#composition list
        set end [lindex $args end]
        if {[lindex $end 0] in [list "_fn" "_call"]} {
            #is_funcl
            set endfunc [lindex $args end]
        } else {
            if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
                #set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}]
                set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]]
            } else {
                set endfunc [list _call 1 3 [list {*}$end]]
            }
        }
        
        if {[llength $args] == 1} {
            return $endfunc
        }
        set comp $endfunc
        set revlist [lreverse [lrange $args 0 end-1]]
        foreach cmdlist $revlist {
            if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
                set is_script 1
                set script [lindex $cmdlist 0]
                set arglist [list data]
                
                set comp [list _fn 1 6 call_script $script $arglist $comp] 
            } else {
                set posn1 [expr {[llength $cmdlist] + 2 + $n}]
                set comp [list _fn $n $posn1 {*}$cmdlist $comp]
            }
        } 
        return $comp
    }
    proc call_script {script argnames args} {
        uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]]
    } 
    proc funcl_script_test {scr} {
        do_funcl_script_test $scr
    }
    proc do_funcl_script_test {scr} {
        #set j "in do_funcl_script_test"
        #set data "xxx"
        #puts '$scr'
        if 1 $scr
    }

    #standard o_ with no script-handling
     proc o_plain args {
        set body ""
        set i 0
        set tails [lrepeat [llength $args] ""]
        #puts stdout "tails: $tails"
        foreach cmdlist $args {
            set t ""
            if {$i > 0} {
                append body { [}
            }
            set posn [lsearch $cmdlist _]
            if {$posn <= 0} {
                append body $cmdlist
                if {$i == [expr {[llength $args] -1}]} {
                    append body " \$data"
                }
                if {$i > 0} {
                    set t {]}
                }
            } else {
                append body [lrange $cmdlist 0 $posn-1]
                if {$i == [expr {[llength $args] -1}]} {
                    append body " \$data"
                }
                set t [lrange $cmdlist $posn+1 end]
                if {$i > 0} {
                    append t { ]}
                }
            }
            lset tails $i $t
            incr i
        }
        append body [join [lreverse $tails] " "]
        #puts stdout "tails: $tails"
        
        return $body
     }
    #timings suggest no faster to split out the first item from the cmdlist loop
}