punkshell/src/modules/punk/lib-0.1.tm

package provide punk::lib [namespace eval punk::lib {
	variable version
	set version 0.1
}]

namespace eval punk::lib {
    >pattern .. Create >libpattern ;#clone to a library factory
    >libpattern .. Construct {args} {
        var o_this
        set o_this @this@
        var o_last_child
        set o_last_child ""
    }

    >libpattern .. Method version {} {
        return 1.0.0
    }

    >libpattern .. Method aliasprefix {pfx} {
        var o_this
        var o_last_child
        if {![string length $o_last_child]} {
            error " . aliasprefix - Create library object with  . new >somename first."
        }
        set patternmethods [$o_this .. PM]
        set aliases [list]
        foreach m $patternmethods {
            set a ${pfx}${m}
            if {[llength [info commands $a]]} {
                puts stderr "WARNING - a command was already present at: $a"
            }
            interp alias "" $a  "" [$o_last_child . $m .]
            lappend aliases $a
        }
        return $aliases
    }
    >libpattern .. Method new {objcmdname} {
        var o_this
        set o_this @this@
        var o_last_child
        set nscaller [uplevel 1 [list namespace current]]
        if {![string match ::* $objcmdname]} {
            if {$nscaller eq "::"} {set nscaller ""}
            set objcmdname ${nscaller}::$objcmdname
        }
        uplevel 1 [list $o_this .. Create $objcmdname]
        set o_last_child $objcmdname
    }

    >libpattern .. Constructor {args} {
        var o_this
        set o_this @this@
    }

    >libpattern .. Clone >ls_lib
    >ls_lib .. PatternMethod tail {args} {
        if {![llength $args]} {
            error "argumenterror cannot retrieve tail on an empty input list" ">ls_lib . tail $args" [list argumenterror tail empty_list]
        }
        lrange $args 1 end
    }
    >ls_lib .. PatternMethod init {args} {
        if {![llength $args]} {
            error "argumenterror cannot retrieve init on an empty input list" ">ls_lib . init $args" [list argumenterror init empty_list]
        }
        lrange $args 0 end-1
    }
    >ls_lib .. PatternMethod head {args} {
        if {![llength $args]} {
            error "argumenterror cannot retrieve head on an empty input list" ">ls_lib . head $args" [list argumenterror head empty_list]
        }
        lindex $args 0
    }
    >ls_lib .. PatternMethod last {args} {
        if {![llength $args]} {
            error "argumenterror cannot retrieve last on an empty input list. Use li.index end to avoid list length check" ">ls_lib . last $args" [list argumenterror last empty_list]
        }
        lindex $args end
    }
    >ls_lib .. PatternMethod elem {val args} {
        expr {$val in $args}
    }
    >ls_lib .. PatternMethod index {idx args} {
        lindex $args $idx
    }
    >ls_lib .. PatternMethod range {s e args} {
        lrange $args $s $e
    }

    #take/drop - haskell-like - but no lazy support REVIEW
    #see also https://www.haskellforall.com/2022/05/why-does-haskells-take-function-accept.html
    >ls_lib .. PatternMethod take {n args} {
        #keep basic behaviour like Haskell ie we allow returning less than n (without error) if insufficient elements
        lrange $args 0 $n-1
    }
    >ls_lib .. PatternMethod drop {n args} {
        lrange $args $n end
    }

    >ls_lib . new >ls 
    >ls_lib . aliasprefix "ls."



    #list item lib
    >libpattern .. Clone >li_lib
    >li_lib .. PatternMethod tail {listdata} {
        if {![llength $listdata]} {
            error "argumenterror cannot retrieve tail on an empty input list" ">li_lib . tail $listdata" [list argumenterror tail empty_list]
        }
        lrange $listdata 1 end
    }
    >li_lib .. PatternMethod init {listdata} {
        if {![llength $listdata]} {
            error "argumenterror cannot retrieve init on an empty input list" ">li_lib . init $listdata" [list argumenterror init empty_list]
        }
        lrange $listdata 0 end-1
    }
    >li_lib .. PatternMethod head {listdata} {
        if {![llength $listdata]} {
            error "argumenterror cannot retrieve head on an empty input list" ">li_lib . head $listdata" [list argumenterror head empty_list]
        }
        lindex $listdata 0
    }
    >li_lib .. PatternMethod last {listdata} {
        if {![llength $listdata]} {
            error "argumenterror cannot retrieve last on an empty input list. Use li.index end to avoid list length check" ">li_lib . last $listdata" [list argumenterror last empty_list]
        }
        lindex $listdata end
    }
    >li_lib .. PatternMethod elem {val listdata} {
        expr {$val in $listdata}
    }
    >li_lib .. PatternMethod index {idx listdata} {
        lindex $listdata $idx
    }
    >li_lib .. PatternMethod range {s e listdata} {
        lrange $listdata $s $e
    }

    #take/drop - haskell-like - but no lazy support REVIEW
    #see also https://www.haskellforall.com/2022/05/why-does-haskells-take-function-accept.html
    >li_lib .. PatternMethod take {n listdata} {
        #keep basic behaviour like Haskell ie we allow returning less than n (without error) if insufficient elements
        lrange $listdata 0 $n-1
    }
    >li_lib .. PatternMethod drop {n listdata} {
        lrange $listdata $n end
    }
    #todo - takeWhile, dropWhile, takeWhileEnd, dropWhileEnd

    >li_lib .. PatternMethod is_list_all_in_list {a b} {
        package require struct::list
        package require struct::set
        set a_in_b [lsort [struct::set intersect [lsort -unique $a] $b ]]
        return [struct::list equal [lsort $a] $a_in_b]
    }
    >li_lib .. PatternMethod is_list_all_ni_list {a b} {
        package require struct::set
        set i [struct::set intersect $a $b]
        return [expr {[llength $i] == 0}]
    }

    >li_lib . new >li 
    >li_lib . aliasprefix "li."

    >pattern .. Create >f_lib

    >f_lib .. Construct {args} {
        var o_this
        set o_this @this@
        var o_last_child
        set o_last_child ""
    }
    >f_lib .. Method version {} {
        return 1.0.0
    }
    >f_lib .. Method aliasprefix {pfx} {
        var o_this
        var o_last_child
        if {![string length $o_last_child]} {
            error ">f_lib . aliasprefix - Create library object with >f_lib . new >somename first."
        }
        set patternmethods [$o_this .. PM]
        set aliases [list]
        foreach m $patternmethods {
            set a ${pfx}${m}
            if {[llength [info commands $a]]} {
                puts stderr "WARNING - a command was already present at: $a"
            }
            interp alias "" $a  "" [$o_last_child . $m .]
            lappend aliases $a
        }
        return $aliases
    }
    >f_lib .. Method new {objcmdname} {
        var o_this
        var o_last_child
        set nscaller [uplevel 1 [list namespace current]]
        if {![string match ::* $objcmdname]} {
            if {$nscaller eq "::"} {set nscaller ""}
            set objcmdname ${nscaller}::$objcmdname
        }
        uplevel 1 [list $o_this .. Create $objcmdname]
        set o_last_child $objcmdname
    }


    >f_lib .. Constructor {args} {
        var o_this
        set o_this @this@
    }

    >f_lib .. PatternMethod foldl {total func sequence} {
        struct::list::Lfold $sequence $total $func
    }
    #note: foldr is not equivalent to just doing a foldl on the reversed list
    #todo - review/test/fix
    >f_lib .. PatternMethod foldr {total func sequence} {
        set this @this@
        if {![llength $sequence]} {
            return $total
        }
        v,h@head,t@tail.=val $sequence |h@head,t@tail>  {
               puts "-->$h"
               $func [$this . foldr $total $func $t] $h
        } <this@,func@,total@| $this $func $total

        return 0
        return $v
    }
    # reduce: simplest case - list of numbers - reduce with +
    # more complex case: list of pipelines (e.g parsers) - reduce with 'andThen' operator of some sort.
    >f_lib .. PatternMethod reduce {func sequence} {
        struct::list::Lfold [lrange $sequence 1 end] [lindex $sequence 0] $func
    }
    >f_lib .. PatternMethod list_map {commandlist list} {
        tailcall lmap item $list $commandlist
    }
    >f_lib .. PatternMethod list_unique {args} {
        set list [concat {*}$args]
        set d [dict create]
        foreach item $list {
            dict set d $item ""
        }
        dict keys $d
    }
    >f_lib .. PatternMethod list_as_lines {args} {
        set list [concat {*}$args]
        join $list \n
    }
    >f_lib .. PatternMethod list_filter_cond {itemcond listval} {
        #maintenance - proc list_filter_cond
        set filtered_list [list]
        set binding {}
        if {[info level] == 1} {
            #up 1 is global 
            set get_vars [list info vars]
        } else {
            set get_vars [list info locals]
        }
        set vars [uplevel 1 {*}$get_vars]
        set posn [lsearch $vars item]
        set vars [lreplace $vars $posn $posn]
        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.
            }
        }
        #lappend binding [list item $args]

        #puts stderr "binding: [join $binding \n]"
        #apply [list $binding $pipescript [uplevel 1 namespace current]]
        foreach item $listval {
            set bindlist [list {*}$binding [list item $item]]
            if {[apply [list $bindlist $itemcond [uplevel 1 namespace current]] ]} {
                lappend filtered_list $item
            }
        }
        return $filtered_list
    }

    >f_lib .. PatternMethod sum_llength {total listval} {
        expr {$total + [llength $listval]}
    }
    >f_lib .. PatternMethod sum_length {total stringval} {
        expr {$total + [string length $stringval]}
    }
    >f_lib .. PatternMethod debug {total item} {
        puts stderr "incr tally: $total item: $item"
        expr {$total + 1}
    }
    >f_lib .. PatternMethod dict_walk {d key} {
        dict get $d $key
    }
    >f_lib .. PatternMethod sum {total num} {
        expr {$total + $num}
    }
    >f_lib .. PatternMethod lcomp {expression args} {
        #from https://wiki.tcl-lang.org/page/lcomp
        set __0__ "lappend __1__ \[expr [list $expression]\]"
        while {[llength $args] && [lindex $args 0] ni {for if with}} {
            append __0__ " \[expr [list [lindex $args 0]]\]"
            set args [lrange $args 1 end]
        }
        set tmpvar 2
        set structure {}
        set upvars {}
        while {[llength $args]} {
            set prefix ""
            switch [lindex $args 0] {
            for {
                set nest [list foreach]
                while {[llength $nest] == 1 || [lindex $args 0] eq "and"} {
                    if {[llength $args] < 4 || [lindex $args 2] ni {in inside}} {
                        error "wrong # operands: must be \"for\" vars \"in?side?\"\
                            vals ?\"and\" vars \"in?side?\" vals? ?...?"
                    }
                    switch [lindex $args 2] {
                    in {
                        lappend nest [lindex $args 1] [lindex $args 3]
                    } inside {
                        lappend nest __${tmpvar}__ [lindex $args 3]
                        append prefix "lassign \$__${tmpvar}__ [lindex $args 1]\n"
                        incr tmpvar
                    }}
                    set args [lrange $args 4 end]
                }
                lappend structure $nest $prefix
            } if {
                if {[llength $args] < 2} {
                    error "wrong # operands: must be \"if\" condition"
                }
                lappend structure [list if [lindex $args 1]] $prefix
                set args [lrange $args 2 end]
            } with {
                if {[llength $args] < 2} {
                    error "wrong # operands: must be \"with\" varlist"
                }
                foreach var [lindex $args 1] {
                    lappend upvars $var $var
                }
                set args [lrange $args 2 end]
            } default {
                error "bad opcode \"[lindex $args 0]\": must be for, if, or with"
            }}
        }
        foreach {prefix nest} [lreverse $structure] {
            set __0__ [concat $nest [list \n$prefix$__0__]]
        }
        if {[llength $upvars]} {
            set __0__ "upvar 1 $upvars; $__0__"
        }
        unset -nocomplain expression args tmpvar prefix nest structure var upvars
        set __1__ ""
        eval $__0__
        return $__1__
    }

    >f_lib . new ::punk::lib::>f
    >f_lib . aliasprefix "f."
    interp alias {} >f {} ::punk::lib::>f
    
    
        #Pattern-matching based functional operations
    >pattern .. Create >P
    >P .. Method map {pattern commandlist sequence} {
        #set segment [string map [list <cmd> $commandlist] {<cmd>}]

        set pipeline [list % {val $item} "|,item,$pattern>" $commandlist <item/0|]
        tailcall % list $pipeline $sequence |p/0,l/1>  {lmap val $l {{*}$p  $val }}
    }

}