snot

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 <Map> 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
snot-basicform:  ?
snot-dialog:  a common dialog container for simple inputs

# 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           <component name>
            #   -configuremethod    <mymethod ?arg ..?>
            #   -cgetmethod         <mymethod ?arg ..?>
            #   -verifier           <cmdprefix returning bool>
            #   -default            <value>
            #   -readonly           <bool>
            #     option can only be set at construction time
            #   -required           <bool>
            #     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 <Event> {script}
        #   bind component <Event> {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!
}

    bind  input   <Control-y>       {event generate %W <<Redo>>; break}

    # 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  <Tab>             {focus [input]; break}
    bind  output  <<ReadOnly>>      {my Flash [output]}
    bind  output  <<Paste>>         {focus [input]; event generate [input] <<Paste>>; break}

    variable Options
    variable hull

    layout {
        grid [top] -sticky nsew
        grid [bottom] -sticky nsew

        }
        bindtags [output] [string map {Text TkshOutput.Text} [bindtags [output]]]
        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 ""} {
                my PlumbInterp $Options(-interp) $Options(-stdout)
            } else {
                my Plumb $Options(-stdout)
            }
        }

        focus [input]
    }

    method OnDestroy {script} {
        variable DestroyList
        lappend DestroyList $script
    }

        set tags [$hull.output tag names current]
        set tag [lsearch -inline $tags "Err *"]
        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}

    # evaluator for -interp:
    method EvalInterp {interp script} {