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...
