Index: README.todo ================================================================== --- README.todo +++ README.todo @@ -1,5 +1,33 @@ +tksh: + - history search + - persistence via sqlite and app_dirs + - ui configuration with snot::dialogs + - menu + - catch paste + - status bar: interp/thread + input help + perf/runtime stats? + tcl version info + - command-line args and menu action to restart + - remote mode? comm or ..? + - debugging: idebug (break to tkcon) and variable watches + - [edit] + - document keystrokes .. the rest of the fucking manual + - namespace browser using treectrl + - widget identifier / browser (because getting to parent will be useful) + - widget inspector? + - [show]: rep a var according to its intrep + - are tabs useful? + +I need objects "with fluent interfaces" for (some of these are well done in easywin): + - menu + - buttonbox exists, but add methods & make it a bit more general (via container?) + - status bar + - a simple editor .. but also external editor + - simplest ever prefs pane (or do I just give user a script in an editor?) + - tabs / panes + +hmm .. sqlite-backed options? Should I talk to Tk's ::option db? + snot-toplevel: the good generic parts of easywin. Go easy. -widget/-window: auto-pack the specified widget? snot-autoscrollbar: use the bind [wm geom] trick, but make it a snodget snot-geom: wrap [grid] and friends to take [_ configure] args. snot-stack and snot-shelf?: homogenous containers ADDED modules/snot-0.1.tm Index: modules/snot-0.1.tm ================================================================== --- /dev/null +++ modules/snot-0.1.tm @@ -0,0 +1,499 @@ +# TODO: +# - report errors for delegates, bindings against undeclared components +# - make hull and Options unconditionally visible at class scope +# - the combination of -delegate and -configuremethod doesn't work +#package require Tk + +# alias, upcall, putl, callback, assert, thunk +package require fun + +namespace eval snot { + + # object constructor: called as [object MyObject {script}]. + proc object {args} { + tailcall object::Create {*}$args + } + + # megawidget constructor: called as [megawidget MyWidget {script}]. + proc megawidget {args} { + tailcall megawidget::Create {*}$args + } + + # the definition namespace - wraps ::oo::define + namespace eval object { + namespace path [list [namespace parent [namespace current]]] + namespace export * + + # object constructor: called as [object MyObject {script}]. + proc Create {classname script} { + set classname [upcall oo::class create $classname] + oo::define $classname superclass Object + Define $classname $script + } + + # fill out the object with tcloo+metaclass script + proc Define {classname script} { + # setup variables that can be manipulated by the creation script: + set options [dict create] + set components [dict create] + + eval $script + + #oo::define $classname mixin Megawidget + oo::define $classname method OptSpec {} [list return $options] + oo::define $classname method Components {} [list return $components] + } + + apply [list {} { + # install initial oo::define forwards: + foreach cmd [info commands ::oo::define::*] { + set cmd [namespace tail $cmd] + if {$cmd eq "self"} continue + proc $cmd {args} [format { + upvar 1 classname classname + tailcall ::oo::define $classname %s {*}$args + } [list $cmd]] + } + + # replacement for oo::define::self + proc class {cmd args} { + upvar 1 classname classname + upcall ::oo::objdefine $classname $cmd {*}$args + } + } [namespace current]] + + # declare components (child widgets): + # component editor text -undo 1 + # will make $hull.editor, accessible in the object as [editor] + proc component {name args} { + # FIXME: support private/renamed components + upcall dict set components $name $args + } + + proc option {name args} { + # Each option is identified by name (-switch) + # and may have: + # -resource StudlyCaps + # -delegate + # -configuremethod + # -cgetmethod + # -verifier + # -default + # -readonly + # option can only be set at construction time + # -required + # option must be provided at construction time + # + # Wildcard delegation: + # option * -delegate hull + # * any unrecognised option (cget/configure) + # will be given to the hull + # * getting all configuration will splice + # in (non-colliding) * from the hull + # Otherwise this option is ignored. + # FIXME: use dictargs + set defaults { + -delegate "" + -resource "" + -configuremethod "" + -cgetmethod "" + -verifier "" + -default "" + -readonly 0 + -required 0 + } + set args [dict merge $defaults $args] + upcall dict set options $name $args + } + + } + + # object base class + oo::class create Object { + variable OptSpec ;# cached from [my OptSpec] + variable Options ;# array + + # constructor and helpers: + constructor {args} { + namespace path [list [namespace qualifiers [self class]] {*}[namespace path]] ;# having to do this kinda sucks + + # figure out where options are going: + set opts [my OptDest $args] + + my InitComponents $opts + my InitConfig [dict get $opts self] + #catch {next {*}$args} + } + + method CreateComponent {cons name args} { + {*}$cons $name {*}$args + return [namespace current]::$name + } + + method InitComponents {optdict} { + dict for {name args} [my Components] { + # gather options + set opts [lassign $args ctor] + set opts [dict merge $opts [dict get $optdict $name]] + + # do magic on options + set opts [dict map {opt val} $opts { + if {[string match -*variable $opt]} { + my varname $val + } elseif {[string match -*command $opt]} { + namespace code $val + } else { + string cat $val + } + }] + + my CreateComponent $ctor $name {*}$opts + } + } + + # initial configuration differs from configuration: + # - required options are required at creation time + # - readonly options can be given at creation time + method InitConfig {optargs} { + # initialise optspec + # fill out defaults and check for required options + dict for {opt spec} [my OptSpec] { + # FIXME: support -delegate with -default + if {[dict get $spec -delegate] ne ""} continue + if {![dict exists $optargs $opt]} { + if {[dict get $spec -required]} { + error "Missing required option $opt" + } + dict set optargs $opt [dict get $spec -default] + } + } + # configure self + my Configure $optargs + # create readonly traces + dict for {option spec} [my OptSpec] { + if {[dict get $spec -readonly]} { + trace add variable [my varname Options($option)] write "\ + error [list "Option \"$option\" is readonly!"]\n\ + list " + } + } + } + + # internal interfaces + # utility for setup. This takes an options dictionary + # and returns a two level dictionary: + # {self {-opt val ...} hull {-opt val ...} component {-opt val ...}} + # So options can be applied in bulk, esp at constructor time + method OptDest {optargs} { + # these need to be present always: + set result { + self "" + hull "" + } + dict for {component _} [my Components] { + dict set result $component "" + } + foreach {opt val} $optargs { + # look up destination + set dest [my Spec $opt -delegate] + if {$dest eq ""} { + set dest self + } + dict set result $dest $opt $val + } + return $result + } + + # returns the specification of an option as a dictionary + # see Megawidget::Options + method Spec {option {switch ""}} { + if {$switch ne ""} {set switch [list $switch]} + try { + return [dict get [my OptSpec] $option {*}$switch] + } on error {} { + # look for a wildcard + dict for {wild spec} [my OptSpec] { + if {[string match $wild $option]} { + return [dict get $spec {*}$switch] + } + } + } + # else it's bad: + error "Unknown option \"$option\"!" + } + + # returns Tk optspec list: + # {-switch resName ResClass defValue value} + method TkSpec {option spec} { + dict with spec { + list $option [string tolower ${-resource} 0 0] ${-resource} ${-default} $Options($option) + } + } + + # internal face of configure with 2N args: + method Configure {optargs} { + # do any verification first: + dict for {option value} $optargs { + set spec [my Spec $option] + set cmd [dict get $spec -verifier] + if {$cmd ne ""} { + if {![uplevel #0 $cmd [list $value]]} { + throw {TK BAD OPTION} "Bad value for \"$option\", should be \[$cmd\], not \"$value\"" + } + } + } + # figure out what options go where + set opts [my OptDest $optargs] + + # apply my own options first + set myopts [dict get $opts self] + dict unset opts self + # FIXME: configuremethods would like it if their defaults + # were applied up front + dict for {option value} $myopts { + set spec [my Spec $option] + set cmd [dict get $spec -configuremethod] + if {$cmd ne ""} { + my {*}$cmd $option $value + } else { + set Options($option) $value + } + } + # apply component configuration last: + dict for {component options} $opts { + if {$options eq ""} continue + $component configure {*}$options + } + } + + # internal face of cget: + method Cget {option} { + set spec [my Spec $option] + + # is it delegated? (includes hull) + set cmd [dict get $spec -delegate] + if {$cmd ne ""} { + tailcall {*}$cmd cget $option + } + + # is it handled by a method? + set cmd [dict get $spec -cgetmethod] + if {$cmd ne ""} { + tailcall my {*}$cmd $option + } + + # else use the array: + return $Options($option) + } + + # internal face of configure with 0/1 arg: + method CgetSpec {{option ""}} { + # returns Tk optspec list: + # {-switch resName ResClass defValue value} + if {$option ne ""} { ;# look up a single option: + set spec [my Spec $option] + + # is it delegated? + set cmd [dict get $spec -delegate] + if {$cmd ne ""} { + return [{*}$cmd cget $option] + } + + return [my TkSpec $option $spec] + } + + # no option - expand everything, including wildcard delegates + set result {} + dict for {option spec} [my OptSpec] { + set cmd [dict get $spec -delegate] + if {$cmd ne ""} { + foreach tkspec [{*}$cmd configure] { + set tkopt [lindex $tkspec 0] + # get everything that matches: + if {[string match $option $tkopt]} { + # except collisions: + if {[info exists Options($tkopt)]} continue + lappend result $tkspec + } + } + } else { + lappend result [my TkSpec $option $spec] + } + } + return $result + } + + # options public interface: + method cget {option} { + my Cget $option + } + method configure {args} { + if {[llength $args] < 2} { + my CgetSpec {*}$args + } else { + my Configure $args + } + } + + } + + # the definition namespace - wraps ::oo::define + namespace eval megawidget { + namespace path [list [namespace parent [namespace current]]] + + namespace import ::snot::object::* + + # megawidget constructor: called as [megawidget MyWidget {script}]. + # Creates a Tk-like constructor named [string tolower $classname]. + proc Create {classname script} { + set classname [upcall oo::class create $classname] + oo::define $classname superclass Megawidget + Define $classname $script + + # cannot simply alias, as ::.win is bad + #upcall alias [string tolower $classname] $classname new + upcall proc [string tolower $classname] args [format { + return [namespace tail [%1$s new {*}$args]] + } [list $classname]] + } + + # fill out the object with tcloo+metaclass script + proc Define {classname script} { + # setup variables that can be manipulated by the creation script: + set hulltype ::ttk::frame + set options [dict create] + set components [dict create] + set bindings [dict create] + + eval $script + + #oo::define $classname mixin Megawidget + oo::define $classname method Hulltype {} [list return $hulltype] + oo::define $classname method OptSpec {} [list return $options] + oo::define $classname method Components {} [list return $components] + oo::define $classname method Bindings {} [list return $bindings] + } + + # extension methods for megawidgets: + # declare the hull type this way. Default is ttk::frame. + # method :hulltype {cls widget args} { + # upcall method Hulltype [list return [list $widget {*}$args]] + # } + proc hulltype {widget args} { + upcall set hulltype [list $widget {*}$args] + } + + # code to physically lay out components - use pack/place/grid + proc layout {script} { + upcall method InitLayout {} $script + } + + # Create a binding. Script is evaluated in the instance's namespace + # bind {script} + # bind component {script} + proc bind {args} { + switch [llength $args] { + 2 { + set component hull + lassign $args event script + } + 3 { + lassign $args component event script + } + default { + error "Bad arguments: expected bind ?component? event script" + } + } + upcall lappend bindings [list $component $event $script] + } + + } + + oo::class create Megawidget { + + superclass ::snot::Object + + variable hull ;# widget name of hull. Other components also available this way. + + # methods OptSpec, Hulltype, Components are injected at creation time + + self unexport create ;# we only support creation with [new] + + # constructor and helpers: + constructor {w args} { + namespace path [list [namespace qualifiers [self class]] {*}[namespace path]] ;# having to do this kinda sucks + + # figure out where options are going: + set opts [my OptDest $args] + + # InitHull does the [rename] dance to tie this obect with the Tk widget + my InitHull $w [dict get $opts hull] + # [self] is now $w + next {*}$args + my InitBindings + my InitLayout + } + + method CreateComponent {ctor name args} { + # construct and wire up component + set w [string trimright $hull .].$name + {*}$ctor $w {*}$args + rename $w [namespace current]::$w ;# rename for ownership + + alias ::$w [namespace current]::$w ;# Tk needs an alias from :: + trace add variable [my varname hull] unset "[list unalias ::$w]; list" + + proc ${name} args [format { + if {$args eq ""} {return %1$s} + %1$s {*}$args + } [list $w]] + } + + method InitHull {w hullopts} { + set hull $w ;# hull is privileged: it gets a shared variable + + # gather options + #FIXME: ? + set defopts [lassign [my Hulltype] hullwidget] + #lassign [my Hulltype] hullwidget defopts + set opts [dict merge $defopts $hullopts] + + # construct and wire up component + set obj [{*}$hullwidget $hull {*}$opts] + rename ::${obj} [namespace current]::${hull} + rename [self] ::${obj} ;# !! + + proc hull args [format { + if {$args eq ""} {return %1$s} + tailcall %1$s {*}$args + } [list $hull]] + + # tie lifetime to hull - closes the loop with [rename] above + trace add command [namespace current]::${hull} delete "[callback my destroy];list " + } + + method InitBindings {} { + foreach binddef [my Bindings] { + lassign $binddef component event script + bind [$component] $event [namespace code $script] ;# magic! + } + } + + method InitLayout {} { + # FIXME: should this have a placeholder? + catch next + } + + # public ttk interface. If these don't exist on the hull, it doesn't matter. + forward state hull state + + # I thought a forward would do here, but no: + #forward instate hull instate + method instate args { + tailcall hull instate {*}$args + } + forward identify hull identify ;# FIXME: shim this for Tk? + } + # and that's it! +} + Index: modules/tksh-0.tm ================================================================== --- modules/tksh-0.tm +++ modules/tksh-0.tm @@ -39,13 +39,15 @@ # TODO: more readline-style bindings: # ^a home ^e end # ^b ^f back/fwd # alt-b alt-f word # ^u ^k erase-to-start erase-to-end + # ^r history-search-interactive bind output {focus [input]; break} bind output <> {my Flash [output]} + bind output <> {focus [input]; event generate [input] <>; break} variable Options variable hull layout { @@ -70,10 +72,17 @@ History create history { {parray ::tcl_platform} {coroeval {after 500 [info coroutine]; puts "yielding [info coroutine]"; yield; puts "done"; expr 501}} } my SetupTags + + # Tk must be loaded like this to avoid TIS/TSM errors on Mac. See bug 0c65cfc14f + if {$Options(-thread) ne ""} { + my eval "package ifneeded Tk [package require Tk] {load {} Tk}" + } elseif {$Options(-interp) ne ""} { + my eval "package ifneeded Tk [package require Tk] {load {} Tk}" + } if {$Options(-stdout) ne ""} { if {$Options(-thread) ne ""} { my PlumbThread $Options(-thread) $Options(-stdout) } elseif {$Options(-interp) ne ""} { @@ -80,10 +89,11 @@ my PlumbInterp $Options(-interp) $Options(-stdout) } else { my Plumb $Options(-stdout) } } + focus [input] } method OnDestroy {script} { variable DestroyList @@ -372,11 +382,11 @@ if {![string match "* Detail" $tag]} {set tag "$tag Detail"} $hull.output tag configure $tag -elide [expr {0 eq [ $hull.output tag cget $tag -elide ]}] } - + # configurable items - see [method Configure]: method Prompt {} {return "\n% "} method IsComplete {script} {info complete $script\n} method Evaluate {script} {list [catch {uplevel #0 $script} e o] $e $o}