Last active
May 25, 2018 22:01
-
-
Save efrecon/4cfa1102b96a0adcc8493ee3d00fee51 to your computer and use it in GitHub Desktop.
druct, C-like structs using dictionaries in Tcl
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 "" | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment