punkshell/src/bootsupport/modules/dictn-0.1.2.tm

# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application dictn 0.1.2
# Meta platform     tcl
# Meta license      <unspecified>
# @@ Meta End



# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Requirements
##e.g package require frobz




# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval dictn {
    namespace export {[a-z]*}
    namespace ensemble create

    namespace eval argdoc {
        variable PUNKARGS
        #non-colour SGR codes
        set I   "\x1b\[3m"                  ;# [a+ italic]
        set NI  "\x1b\[23m"                 ;# [a+ noitalic]
        set B   "\x1b\[1m"                  ;# [a+ bold]
        set N   "\x1b\[22m"                 ;# [a+ normal]
        set T   "\x1b\[1\;4m"               ;# [a+ bold underline]
        set NT  "\x1b\[22\;24m\x1b\[4:0m"   ;# [a+ normal nounderline]
    }
}


## ::dictn::append
#
tcl::namespace::eval ::dictn::argdoc {
    lappend PUNKARGS [list {
        @id     -id     ::dictn::append
        @cmd    -name     dictn::append\
            -summary\
            "Append a single string to the value at dict path."\
            -help\
            "Append a single string to the value at a given dictionary path.
            
            This can of course 'ruin' a nested dict if applied to the wrong element 
             - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
                 %set list {a b {c d}}
                 %append list x
                 a b {c d}x
              IOW - don't do that unless you really know that's what you want.
            
            Note than unlike dict append - only a single value is accepted for appending.
            "
        @values -min 2 -max 3
        dictvar -type string
        path -type list
        value -type any -default "" -optional 1
    }]
}
proc ::dictn::append {dictvar path {value {}}} {
    if {[llength $path] == 1} {
        uplevel 1 [list dict append $dictvar $path $value]
    } else {
        upvar 1 $dictvar dvar

        ::set str [dict get $dvar {*}$path]
        append str $value 
        dict set dvar {*}$path $str
    }
}

proc ::dictn::create {args} {
    ::set data {}    
    foreach {path val} $args {
            dict set data {*}$path $val
    }
    return $data
}

proc ::dictn::exists {dictval path} {
    return [dict exists $dictval {*}$path]
}

proc ::dictn::filter {dictval path filterType args} {
    ::set sub [dict get $dictval {*}$path]
    dict filter $sub $filterType {*}$args
}

proc ::dictn::for {keyvalvars dictval path body} {
    ::set sub [dict get $dictval {*}$path]
    dict for $keyvalvars $sub $body
}

proc ::dictn::get {dictval {path {}}} {
    return [dict get $dictval {*}$path]
}
tcl::namespace::eval ::dictn::argdoc {
    lappend PUNKARGS [list {
        @id     -id     ::dictn::getn
        @cmd    -name     dictn::getn\
            -summary\
            "Get one or more paths in a dict simultaneously."\
            -help\
            ""
        @values -min 1 -max -1
        dictvar -type string
        path -type list -multiple 1
    }]
}
proc ::dictn::getn {dictval args} {
    if {![llength $args]} {
        return [::tcl::dict::get $dictval]
    }
    lmap path $args {::tcl::dict::get $dictval {*}$path}
}


if {[info commands ::tcl::dict::getdef] ne ""} {
    #tcl 9+
    proc ::dictn::getdef {dictval path default} {
        return [dict getdef $dictval {*}$path $default]
    }

    proc ::dictn::getwithdefault {dictval path default} {
        return [dict getdef $dictval {*}$path $default]
    }

    proc ::dictn::incr {dictvar path {increment 1} } {
        upvar 1 $dictvar dvar
        if {[llength $path] == 1} {
            return [::tcl::dict::incr dvar $path $increment]
        }
        if {[::tcl::info::exists dvar]} {
            ::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}]
        }
        return [::tcl::dict::set dvar {*}$path $increment]
    }
    #test - compare disassembly 
    proc ::dictn::incr2 {dictvar path {increment 1} } {
        if {[llength $path] == 1} {
            uplevel 1 [list dict incr $dictvar $path $increment]
        } else {
            upvar 1 $dictvar dvar
            if {![::info exists dvar]} {
                dict set dvar {*}$path $increment
            } else {
                ::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}]
                dict set dvar {*}$path $newval
            }
            return $dvar
        }
    }
} else {
    #tcl < 9
    proc ::dictn::getdef {dictval path default} {
        if {[tcl::dict::exists $dictval {*}$path]} {
            return [tcl::dict::get $dictval {*}$path]
        } else {
            return $default 
        }
    }
    proc ::dictn::getwithdefault {dictval path default} {
        if {[tcl::dict::exists $dictval {*}$path]} {
            return [tcl::dict::get $dictval {*}$path]
        } else {
            return $default 
        }
    }
    proc ::dictn::incr {dictvar path {increment {}} } {
        if {$increment eq ""} {
            ::set increment 1
        }
        if {[llength $path] == 1} {
            uplevel 1 [list dict incr $dictvar $path $increment]
        } else {
            upvar 1 $dictvar dvar
            if {![::info exists dvar]} {
                dict set dvar {*}$path $increment
            } else {
                if {![dict exists $dvar {*}$path]} {
                    ::set val 0
                } else {
                    ::set val [dict get $dvar {*}$path]
                }
                ::set newval [expr {$val + $increment}]
                dict set dvar {*}$path $newval
            }
            return $dvar
        }
    }
}

proc ::dictn::info {dictval {path {}}} {
    if {![string length $path]} {
        return [dict info $dictval]
    } else {
        ::set sub [dict get $dictval {*}$path]
        return [dict info $sub]
    }
}

proc ::dictn::keys {dictval {path {}} {glob {}}} {
    ::set sub [dict get $dictval {*}$path]
    if {[string length $glob]} {
        return [dict keys $sub $glob]
    } else {
        return [dict keys $sub]
    }
}

proc ::dictn::lappend {dictvar path args} {
    if {[llength $path] == 1} {
        uplevel 1 [list dict lappend $dictvar $path {*}$args]
    } else {
        upvar 1 $dictvar dvar

        ::set list [dict get $dvar {*}$path]
        ::lappend list {*}$args
        dict set dvar {*}$path $list
    }
}

proc ::dictn::merge {args} {
    error "nested merge not yet supported"
}

#dictn remove dictionaryValue ?path ...?
proc ::dictn::remove {dictval args} {
    ::set basic [list] ;#buffer basic (1element path) removals to do in a single call.

    foreach path $args {
        if {[llength $path] == 1} {
            ::lappend basic $path
        } else {
            #extract,modify,replace
            ::set subpath [lrange $path 0 end-1]

            ::set sub [dict get $dictval {*}$subpath]
            ::set sub [dict remove $sub [lindex $path end]]

            dict set dictval {*}$subpath $sub
        }
    }

    if {[llength $basic]} {
        return [dict remove $dictval {*}$basic]
    } else {
        return $dictval
    }
}


proc ::dictn::replace {dictval args} {
    ::set basic [list] ;#buffer basic (1element path) replacements to do in a single call.

    foreach {path val} $args {
        if {[llength $path] == 1} {
            ::lappend basic $path $val
        } else {
            #extract,modify,replace
            ::set subpath [lrange $path 0 end-1]

            ::set sub [dict get $dictval {*}$subpath]
            ::set sub [dict replace $sub [lindex $path end] $val]

            dict set dictval {*}$subpath $sub                        
        }
    }


    if {[llength $basic]} {
        return [dict replace $dictval {*}$basic]
    } else {
        return $dictval
    }
}


proc ::dictn::set {dictvar path newval} {
    upvar 1 $dictvar dvar
    return [dict set dvar {*}$path $newval]
}

tcl::namespace::eval ::dictn::argdoc {
    lappend PUNKARGS [list {
        @id     -id     ::dictn::setn
        @cmd    -name     dictn::setn\
            -summary\
            "Set one or more paths in a dict to value(s)"\
            -help\
            ""
        @values -min 3 -max -1
        dictvar -type string
        path_newval -type {path newval} -multiple 1
    }]
}
proc ::dictn::setn {dictvar args} {
    if {[llength $args] == 0} {
        error "dictn::setn requires at least one <path> <newval> pair"
    }
    if {[llength $args] % 2 != 0} {
        error "dictn::setn requires trailing <path> <newval> pairs"
    }
    upvar 1 $dictvar dvar
    foreach {p v} $args {
        ::tcl::dict::set dvar {*}$p $v
    }
    return $dvar
}

proc ::dictn::size {dictval {path {}}} {
    return [dict size [dict get $dictval {*}$path]]
}

proc ::dictn::unset {dictvar path} {
    upvar 1 $dictvar dvar
    return [dict unset dvar {*}$path    
}

proc ::dictn::update {dictvar args} {
    ::set body [lindex $args end]
    ::set maplist [lrange $args 0 end-1]

    upvar 1 $dictvar dvar
    foreach {path var} $maplist {
        if {[dict exists $dvar {*}$path]} {
            uplevel 1 [list set $var [dict get $dvar $path]]
        }
    }

    catch {uplevel 1 $body} result
    
    foreach {path var} $maplist {
        if {[dict exists $dvar {*}$path]} {
            upvar 1 $var $var
            if {![::info exists $var]} {
                uplevel 1 [list dict unset $dictvar {*}$path]
            } else {
                uplevel 1 [list dict set $dictvar {*}$path [::set $var]]
            }
        }        
    }
    return $result
}

#an experiment.
proc ::dictn::Applyupdate {dictvar args} {
    ::set body [lindex $args end]
    ::set maplist [lrange $args 0 end-1]

    upvar 1 $dictvar dvar

    ::set headscript ""
    ::set i 0
    foreach {path var} $maplist {
        if {[dict exists $dvar {*}$path]} {
            #uplevel 1 [list set $var [dict get $dvar $path]]
            ::lappend arglist $var 
            ::lappend vallist [dict get $dvar {*}$path]
            ::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ]
            ::append headscript \n
            ::incr i
        }
    }

    ::set body $headscript\r\n$body

    puts stderr "BODY: $body"
    
    #set result [apply [list args $body] {*}$vallist]
    catch {apply [list args $body] {*}$vallist} result

    foreach {path var} $maplist {
        if {[dict exists $dvar {*}$path] && [::info exists $var]} {
            dict set dvar {*}$path [::set $var]
        }        
    }
    return $result
}

proc ::dictn::values {dictval {path {}} {glob {}}} {
    ::set sub [dict get $dictval {*}$path]
    if {[string length $glob]} {
        return [dict values $sub $glob]
    } else {
        return [dict values $sub]
    }
}

tcl::namespace::eval ::dictn::argdoc {
    lappend PUNKARGS [list {
        @id     -id     ::dictn::with
        @cmd    -name     dictn::with\
            -summary\
            "Execute script for each key at dict path."\
            -help\
            "Execute the Tcl script in body with the value for each key within the
            given key-path mapped to either variables or keys in a specified array.

            If the name of an array variable is not supplied for arrayvar,
            dictn with behaves like dict with, except that it accepts a list
            for the possibly nested key-path instead of separate arguments.

            The subkeys of the dict at the given key-path will create variables
            in the calling scope.
            
            If an arrayvar is passed, an array of that name in the calling
            scope will be populated with keys and values from the subkeys and
            values of the dict at the given key-path."
        @form -form standard
        @values -min 3 -max 3
        dictvar -type string
        path -type list
        body -type string

        @form -form array
        @values -min 4 -max 4
        dictvar -type string
        path -type list
        arrayvar -type string -help\
            "Name of array variable in which key values are
            stored for the given dict path.
            This prevents key values being used as variable
            names in the calling scope, instead capturing them
            as keys in the single specified array at the calling
            scope."
        body -type string
    }]
}
# Standard form:
#'dictn with dictVariable path body'  
#
# Extended form:
#'dictn with dictVariable path arrayVariable body' 
#
proc ::dictn::with {dictvar path args} {
    if {[llength $args] == 1} {
        ::set body [lindex $args 0]
        return [uplevel 1 [list dict with $dictvar {*}$path $body]]
    } else {
        upvar 1 $dictvar dvar
        ::lassign $args arrayname body

        upvar 1 $arrayname arr
        array set arr [dict get $dvar {*}$path]
        ::set prevkeys [array names arr]

        catch {uplevel 1 $body} result


        foreach k $prevkeys {
            if {![::info exists arr($k)]} {
                dict unset $dvar {*}$path $k
            }
        }
        foreach k [array names arr] {
            dict set $dvar {*}$path $k $arr($k)
        }

        return $result
    }   
}






::tcl::namespace::eval ::punk::args::register {
    #use fully qualified so 8.6 doesn't find existing var in global namespace
    lappend ::punk::args::register::NAMESPACES ::dictn
}





# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Ready   
package provide dictn [namespace eval dictn {
    variable version
    ::set version 0.1.2 
}]
return