Compositional Tk

NEM 17 Oct 2005: Here's an experiment with combining Tk widgets with namespaces as another attempt at a megawidget package. Instead of being based on an OO design, this one is based on a simple compositional syntax: you create nested hierarchies of widgets by simply nesting them inside one another. It's not quite as compositional as I'd like it yet, but it illustrates the general idea. Also, beware: widget path-names are currently tied to the namespace hierarchy, so you should either fully-qualify widget names (as you have to in Tk), or always create widgets from the global namespace. I intend to fix that behaviour at some point. Without further ado, some code:

 # comptk.tcl --
 #        Compositional Tk: an experiment on making Tk widget composition
 #        simpler.
 # Copyright (c) 2005 by Neil Madden ([email protected]).
 # License: Same as Tcl

 package require Tcl        8.4
 package require Tk        8.4

 package provide comptk        0.1

 namespace eval ::comptk {

    proc Dispatch {fqname args} {
        if {[llength $args] == 0} {
            return [string map {:: .} $fqname]
        } else {
            uplevel 1 [list namespace eval $fqname $args]
    proc Values {arrName} {
        upvar 1 $arrName array
        set ret [list]
        foreach item [array names array] {
            lappend ret $array($item)
        return $ret
    # Option parsing
    proc CheckOpts {opts arglist} {
        if {[lindex $opts end] eq "args"} {
            set have_args 1
            set opts [lrange $opts 0 end-1]
        } else {
            set have_args 0
        array set options { }
        # Defaults
        foreach item $opts {
            if {[llength $item] == 2} {
                set options([lindex $item 0]) [lindex $item 1]
        set pass [list]
        foreach {name value} $arglist {
            # Remove leading -
            set sname [string range $name 1 end]
            if {[lsearch -exact $opts $sname] > -1} {
                set options($sname) $value
            } elseif {$have_args} {
                lappend pass $name $value
            } else {
                error "unknown option \"$sname\""
        set ret [list]
        foreach item $opts {
            if {[info exists options($item)]} {
                lappend ret $options($item)
            } else {
                error "no value specified for option \"$item\""
        if {$have_args} {
            return [concat $ret $pass]
        } else {
            return $ret
    proc Resolve {name} {
        if {[string index $name 0] eq "."} {
            # Fully qualified
            return [string map {. ::} $name]
        # Note! uplevel _2_...
        set ns [uplevel 2 [list namespace current]]
        if {$ns eq "::"} {
            set fqname ::[string map {. ::} $name]
        } else {
            set fqname ${ns}::[string map {. ::} $name]
    proc In {ns params args body} {
        set env [CheckOpts $params $args]
        set tmp ${ns}::InTmp[clock clicks]
        proc $tmp $params $body
        uplevel #0 [linsert $env 0 $tmp]
        rename $tmp {}
    proc self {args} {
        set ns [uplevel 1 [list namespace current]]
        if {[llength $args]} {
            set name [lindex $args 0]
            return [lreplace $args 0 0 [string map {:: .} $ns].$name]
        } else {
            return [string map {:: .} $ns]
    proc widget {name params body} {
        set ns [uplevel 1 { namespace current }]
        interp alias {} ${ns}::$name {} \
            [namespace current]::Create $params $body
        return $name
    proc Create {opts script name args} {
        if {([llength $args] %2) == 1} {
            set body [lindex $args end]
            set args [lrange $args 0 end-1]
        } else { set body "" }
        set fqname [Resolve $name]
        namespace eval $fqname { namespace import -force ::comptk::* }
        In $fqname $opts $args $script
        namespace eval $fqname $body
        interp alias {} $fqname {} ::comptk::Dispatch $fqname
        return $name
    proc widgetadaptor {name {target {}}} {
        if {![string length $target]} { set target ::$name }
        uplevel 1 [list ::comptk::widget $name args [format {
            eval [linsert $args 0 %s [self]]
        } [list $target]]]
    widget window {title args} {
        eval toplevel [self] $args
        wm title [self] $title
    widgetadaptor text 
    widgetadaptor scrollbar
    widgetadaptor entry
    # Other widgets...
    namespace export {[a-z]*}

Now that we have the basic package, here is some demo code that creates a new megawidget that is the beginnings of a simple text editor:

 # Withdraw root window
 wm withdraw .
 # A simple test
 comptk::widget texteditor {title} {
     comptk::window [self] -title $title {
        text t -yscrollcommand [self vsb set] -xscrollcommand [self hsb set]
        scrollbar vsb -orient vertical -command [self t yview]
        scrollbar hsb -orient horizontal -command [self t xview]
        entry status -textvariable [namespace current]::status
     grid [t]                 -row 0 -column 0 -sticky nsew
     grid [vsb]                -row 0 -column 1 -sticky ns
     grid [hsb]                -row 1 -column 0 -sticky ew
     grid [status]        -row 2 -column 0 -sticky ew -columnspan 2
     grid rowconfigure [self] 0 -weight 1
     grid columnconfigure [self] 0 -weight 1
 texteditor foo -title "CompTk Test"
 # Set the status to something nice:
 foo set status "Hello, World!"
 bind [foo] <Destroy> { exit }

Note little touches like that [foo set status ...] stuff. Making widgets into namespaces comes along with some bonuses like that. Making a new text editor is as simple as just:

 texteditor bar -title "Another editor!"
 bar set status "More status messages..."

Obviously there is a lot of polish to add before this is as industrial-quality as, say snit. It might be nice to combine this with Traits for adding orthogonal behaviours to widgets (e.g., undo etc). Widget hierarchies are ensembles too, so you can do stuff like:

 [bar status] configure -text

Ideally, that would be just [bar status configure -text], but I need to add some magic for that to work...