oo tk experiment

tcl::tm::path add ../modules

#
# An experiment in TclOO widgets as a transparent facade layer over Tk
#
# .. looks pretty good, so far.  There's plenty of undesirable overlap with names unless we're very careful.
# Capitalising window names might be sufficient safety?
#
# probably wants more methods for ttk ..
#
# options needs opts, and learning from snit.
#
# making classes out of these is going to be the kicker!
#

package require pkg
package require tests
package require debug
package require repl

pkg -export * Window {

    proc windowcontext {} {}

    oo::class create Widget {
        variable w
        constructor {cmd args} {
            set w [uplevel 1 windowcontext].[namespace tail [self object]]
            $cmd $w {*}$args
            rename $w [set nsw [namespace current]::$w]
            namespace export $w
            namespace eval :: [list namespace import $nsw]
            proc windowcontext {} [list return $w]
            set griddefaults {}
        }
        method w {} {return $w}
        method widget {cmd name args} {
            Widget create $name $cmd {*}[my WidgetArgs $args]
            oo::objdefine [self] forward $name $name
            return $name
        }
        method WidgetArgs {arglist} {
            set q 0
            lmap a $arglist {
                if {$q} {
                    if {![string match ::* $a]} {
                        debug assert {$a in [info object variables [self]]}
                        set q 0
                        my varname $a
                    } else {
                        set a
                    }
                } else {
                    if {[string match -*variable $a]} {
                        set q 1
                    }
                    set a
                }
            }
        }

        method configure args {
            if {![llength $args]} {
                tailcall $w configure
            }
            if {[string match -* [lindex $args 0]]} {
                tailcall $w configure $args
            }
            set args [lassign $args cmd]
            [$cmd w] configure {*}[my WidgetArgs $args]
        }

        method destroy args {
            if {$args eq ""} {
                next
            } else {
                destroy {*}[my ItemArgs $args]
            }
        }

        variable griddefaults
        method griddefaults args {
            set griddefaults $args
        }
        method packdefaults args {
            set griddefaults $args
        }

        method grid {cmd args} {
            if {$cmd in "anchor bbox location size propagate slaves configure rowconfigure columnconfigure"} {
                grid $cmd $w {*}[my ItemArgs {*}$args]
            } else {
                grid {*}[my GridArgs $cmd {*}$args] -in $w
            }
        }
        method pack {cmd args} {
            if {$cmd in "propagate slaves"} {
                pack $cmd $w {*}[my ItemArgs {*}$args]
            } else {
                pack {*}[my GridArgs $cmd {*}$args] -in $w
            }
        }
        method ItemArgs {args} {
            set i 0
            set args [lmap a $args {
                if {[string match -* $a]} {
                    incr i
                }
                expr {$i ? $a : [$a w]}
            }]
        }
        method GridArgs {args} {
            set i 0
            array set def $griddefaults
            set args [lmap a $args {
                if {[string match -* $a]} {
                    unset -nocomplain def($a)
                    incr i
                }
                expr {$i ? $a : [$a w]}
            }]
            concat $args [array get def]
        }

        method bind {event argspec body args} {
            oo::objdefine [self] method $event [my BindArgs $argspec] $body
            oo::objdefine [self] export $event
            set cmdargs [my BindCmdArgs $argspec]
            bind [my w] $event [list [self] $event {*}$cmdargs {*}$args]
        }
        method BindArgs {argspec} {
            lmap a $argspec {
                string trimleft $a %
            }
        }
        method BindCmdArgs {argspec} {
            lmap a $argspec {
                if {![string match %* $a]} break
                set a
            }
        }

        method bindtags args {
            tailcall bindtags [my w] {*}$args
        }

        variable options
        method options {} {
            lsort -dictionary [concat [array values options] [$w configure]]
        }
        method option {option resource class default} {
            set options($option) [list $resource $class $default $default]
            # .. learn more from snit
        }

        method method {name argspec body} {
            oo::objdefine [self] method $name $argspec $body
            oo::objdefine [self] export $name
        }
        method variable args {
            oo::objdefine [self] variable {*}$args
        }
        method get {name} {
            set [my varname $name]
        }
        method set args {
            foreach {name val} $args {
                set [my varname $name] $val
            }
        }
        method getdict {} {
            lconcat name [info object variables [self]] {
                list $name [set [my varname $name]]
            }
        }

        method unknown {args} {
            if {$args eq ""} {
                return [my w]
            } else {
                tailcall [my w] {*}$args
            }
        }
    }
}

if 1 {
    package require Tk
    Widget create t toplevel
    t widget entry e1
    t widget button b1 -command {puts hello}
    t griddefaults -sticky nsew
    t grid e1
    t grid b1
    t grid [t widget button b2 -text okde]
    t grid rowconfigure b1 -weight 1
    t e1 insert end "lalala"
    t configure b1 -text "Press me"
    t bind <1> {%W %x %y a} {           ;# implicitly creates a method on the object ..
        puts "$W $x $y: $ack ($a)"      ;# that can resolve object variables!
    } five                              ;# remember: % args must come first!
    t variable ack
    t configure e1 -textvariable ack    ;# ack is resolved in t's scope!
}

if 1 {
    chan configure stdin -blocking 0
    chan configure stdout -buffering none
    coroutine repl repl::chan stdin stdout
    puts vwaiting
    vwait forever
}