druct, C-like structs using dictionaries in Tcl

druct.tcl

namespace eval ::druct {
    namespace eval types {}
    namespace export {[a-z]*}
    namespace ensemble create
}

proc ::druct::new { type varname } {
    set typedef [Definition $type]
    if { ![info exists $typedef] } {
        return -code error "$type does not exist!"
    }

    # Create empty dict
    uplevel [list set $varname [dict create]]

    # Initialise dictionary
    foreach def [set $typedef] {
        set k [lindex $def 0]
        set v ""
        foreach {opt val} [lrange $def 1 end] {
            set opt [string tolower [string trimleft $opt -]]
            if { $opt eq "default" } {
                set v $val
                break
            }
        }
        uplevel [list dict set $varname $k $v]
    }

    # Install traces
    set nspace ::[string trim [uplevel namespace current] :]
    uplevel [list trace variable $varname w [list [namespace current]::CheckType $type $nspace]]
    CheckType $type $nspace $varname {} w
}


proc ::druct::CheckKey { nspace k opts varname arrkey op } {
    set varname [string trimright $nspace :]::[string trimleft $varname :]
    switch -- $op {
        "w" {
            CheckVal $nspace $varname $k $opts 2
        }
    }
}

proc ::druct::CheckType { type nspace varname arrkey op } {
    set varname [string trimright $nspace :]::[string trimleft $varname :]
    switch -- $op {
        "w" {
            set typedef [Definition $type]
            foreach def [set $typedef] {
                set k [lindex $def 0]
                set opts [lrange $def 1 end]
                CheckVal $nspace $varname $k $opts 2
            }
        }
    }
}


proc ::druct::CheckVal { nspace varname k opts {lvl 1}} {
    set varname [string trimright $nspace :]::[string trimleft $varname :]
    if { [GetOpt opts -type type] } {
        switch -- $type {
            "alnum" -
            "alpha" -
            "ascii" -
            "control" -
            "boolean" -
            "digit" -
            "double" -
            "entier" -
            "false" -
            "graph" -
            "integer" -
            "list" -
            "lower" -
            "print" -
            "punct" -
            "space" -
            "true" -
            "upper" -
            "wideinteger" -
            "wordchar" -
            "xdigit" {
                set val [uplevel $lvl [list dict get [set $varname] $k]]
                IsA $val $type $opts \
                        "$k is not of type $type in $varname"
                if { $type eq "list" } {
                    if { [GetOpt opts -items subtype] } {
                        foreach i $val {
                            IsA $i $subtype $opts \
                                "Item $i in list at $k is not of type $subtype in $varname"
                        }
                    }
                }
            }
            "enum" {
                if { [GetOpt opts -values vals] } {
                    set val [uplevel [list dict get [set $varname] $k]]
                    if { $val ni $vals } {
                        return -code error "Value of $k is not one of [join $vals ,\ ]"
                    }
                }
            }
        }
    }
}

proc ::druct::IsA { val type opts msg } {
    set strict [GetOpt opts -strict]
    if { $strict } {
        if { ![string is $type -strict $val] } {
            return -code error $msg
        }
    } else {
        if { ![string is $type $val] } {
            return -code error $msg
        }
    }

}

proc ::druct::typedef { type args } {
    set [Definition $type] $args
}

proc ::druct::typeadd { type args } {
    lappend [Definition $type] $args
}

proc ::druct::keycheck { varname k args } {
    set nspace ::[string trim [uplevel namespace current] :]
    uplevel [list trace variable $varname w [list [namespace current]::CheckKey $nspace $k $args]]
    CheckKey $nspace $k $args $varname {} w
    
}

proc ::druct::Definition { type } {
    set type [string map [list ":" "_"] [string trimleft $type :]]
    return [namespace current]::types::$type
}

proc ::druct::GetOpt {_argv name {_var ""} {default ""}} {
    upvar 1 $_argv argv $_var var
    set pos [lsearch -regexp $argv ^$name]
    if {$pos>=0} {
        set to $pos
        if {$_var ne ""} {
            set var [lindex $argv [incr to]]
        }
        set argv [lreplace $argv $pos $to]
        return 1
    } else {
        if {[llength [info level 0]] == 5} {set var $default}
        return 0
    }
}

if {[info exists argv0] && [file tail [info script]] eq [file tail $argv0]} {
    namespace eval ::test {}
    # Create a type called ::test::mytype
    druct typedef ::test::mytype {
        id -type integer -default 0
    } {
        choice -type enum -values {DOING DONE ONGOING} -default DOING
    }
    # Add another key to the type, this type of programming can be used to avoid
    # the multiple lists (and lines) from the declaration style above
    druct typeadd ::test::mytype \
            integers -type list -items integer
    # Create an "instance" of the type. Creating the variable in the same
    # namespace as the type is not mandatory, as you can see.  The variable will
    # automatically be a dictionary and will be initialised to all defaults
    druct new ::test::mytype mydict
    dict set mydict id 45
    # the following would fail
    #dict set mydict id fhrj
    dict set mydict choice DONE
    # the following would fail
    #dict set mydict choice MAYBE
    dict lappend mydict integers 45
    # the following would fail
    #dict lappend mydict integers abc

    # You can also skip type definitions and simply put constraints on the keys
    # of an already existing dictionary...
    dict set ::test::onedict thekey 0
    druct keycheck ::test::onedict thekey -type integer
    dict set ::test::onedict anotherkey 0.6
    druct keycheck ::test::onedict anotherkey -type double -strict
    # the following would fail
    dict set ::test::onedict thekey 5
    # dict set ::test::onedict thekey abc
    dict set ::test::onedict anotherkey 6.7
    dict set ::test::onedict anotherkey ""
}