Basique - OO-like namespaces

Sarnold thinks that classes should look, as much as possible, like namespaces because it is the current encapsulation model. It may be extreme, but some developers may want to quickly convert a namespace into a Class or Megawidget, while the opposite would not be as simple. I would like to see:

namespace class foo {
    common counter
    variable names

    proc __init__ {args} {
        common counter
        incr counter
        variable names
        array set names $args
    }

    # it has to look like a normal Tcl proc, so it has an arglist
    proc __destroy__ {} {
        common counter
        incr counter -1
    }

    proc display {} {
        variable names
        puts "My name is $names(first) $names(last)"
    }

    proc count {} {
        common counter
        return $counter
    }
}
foo new name first Richard last Heinz
name destroy
set name [foo %AUTO% first Richard last Heinz]
$name display
set name::names(first) George
$name display
# generates an error, because it is an instance method
#foo display
$name destroy

Where common would behave like variable, with a static qualifier. I submit that a sequence of variable bar may be replaced by instance command that wraps all variable calls related to (instance) variables.


basique.tcl

namespace eval ::basique {
    namespace export class
    variable classes
    array set classes {}
    
    proc class {name code} {
        if {[string range $name 0 1] ne {::}} {
            set name ::$name
        }
        variable classes
        if {[info exists classes($name)]} {
            cdelete $name
        }
        set common_prelude [string map [list %NAME% $name] {
            # does nothing
            proc variable {var args} {
                lappend ::basique::classes(%NAME%,instvars) $var
            }
            # provide common variable statement
            proc common {var args} {
                if {[llength $args] > 1} {
                    error {common varname ?default?}
                }
                if {[llength $args] == 0} {
                    uplevel 1 ::variable $var
                    return
                }
                uplevel 1 ::variable $var [lindex $args 0]
                return
            }
            proc alias {name args} {
                if {[llength $name] != 1} {
                    error {cannot create such a composite alias}
                }
                proc $name {args} [string map [list ARGS $args] {
                    eval [linsert $args 0 ARGS]
                }]
            }
            proc component {var args} {
                foreach {opt val} $args {
                    switch -- $opt {
                        -common         {set common $val}
                        -initscript     {::basique::initscript    %NAME% $val $var $common}
                        -destroyscript  {::basique::destroyscript %NAME% $val $var $common}
                        default {
                            error {option should be one of : -common -initscript -destroyscript}
                        }
                    }
                }
                if {![info exists common] || !$common} {
                    return
                }
                proc $var {subcmd args} [string map [list VAR $var] {
                    common VAR
                    uplevel 1 [linsert $args 0 $VAR $subcmd]
                }]
            }
        }]
        namespace eval $name $common_prelude\n$code
        if {[info exists classes($name,compinit)]} {
            namespace eval $name $classes($name,compinit)
        }
        catch {${name}::__classinit__}
        set classes($name) $code
        CreateClass $name
    }
    
    
    proc initscript {class script var common} {
        variable classes
        if {$common} {
            append classes($class,compinit) "common $var\n $script\n"
        } else  {
            append classes($class,instcompinit) "variable $var\n $script\n"
        }
    }
    
    proc destroyscript {class script var common} {
        variable classes
        if {$common} {
            append classes($class,compdestroy) "common $var\n $script\n"
        } else  {
            append classes($class,instcompdestroy) "variable $var\n $script\n"
        }
    }
    
    proc cdelete {name} {
        variable classes
        unset classes($name)
        catch {${name}::__classdestroy__}
        catch {namespace eval $name $classes($name,compdestroy)}
        foreach sub {instvars compinit instcompinit compdestroy instcompdestroy} {
            catch {unset classes($name,$sub)}
        }
        catch {namespace delete $name}
        catch {rename $name {}}
    }
    
    # crée la commande qui instanciera les objets
    proc CreateClass {name} {
        variable classes
        # the 'real' constructor (__init__ is the one at user level)
        # le constructeur réel (le constructeur public est __init__)
        proc $name {args} [string map [list %NAME% $name] {
            if {![llength $args]} {
                set args {%AUTO%}
            }
            if {[lindex $args 0] eq "%AUTO%"} {
                set args [linsert $args 0 new]
            }
            switch -- [lindex $args 0] {
                new {
                    set instance [lindex $args 1]
                    if {$instance eq "%AUTO%"} {
                        set instance [::basique::autoname %NAME%]
                    }
                    set args [lrange $args 2 end]
                }
                default {
                    return [uplevel 1 namespace eval %NAME% $args]
                }
            }
            if {[string range $instance 0 1] ne {::}} {
                set instance ::$instance
            }
            # creates the prelude
            set instance_prelude [string map [list %OBJ% $instance] {
                proc common {var args} {
                    if {[llength $args]>1} {
                        error {common var ?default?}
                    }
                    if {[llength $args]==0} {
                        uplevel 1 [list upvar %NAME%::$var $var]
                    }
                }
                proc body {name arglist body} {
                    proc %OBJ%::$name $arglist $body
                }
                proc . {varname} {
                    return %OBJ%::$varname
                }
                proc self {} {
                    return %OBJ%
                }
                proc -> {varname} {
                    variable $varname
                    set $varname
                }
                proc component {var args} {
                    foreach {opt val} $args {
                        switch -- $opt {
                            -common       {set common $val}
                            -initscript - -destroyscript {}
                            default {
                                error {option should be one of : -common -initscript -destroyscript}
                            }
                        }
                    }
                    if {![info exists common] || !$common} {
                        set type variable
                        uplevel 1 variable $var
                    } else  {
                        set type common
                    }
                    proc $var {subcmd args} [string map [list TYPE $type VAR $var] {
                        TYPE VAR
                        uplevel 1 [linsert $args 0 $VAR $subcmd]
                    }]
                }
                proc alias {name args} {
                    if {[llength $name] != 1} {
                        error {cannot create such a composite alias}
                    }
                    proc $name {args} [string map [list ARGS $args] {
                        uplevel 1 [linsert $args 0 ARGS]
                    }]
                }
            }]
            # insert 'instance' where you want quickly to get instance variables
            # (instead, you would have to type lots of 'variable' statements)
            append instance_prelude "proc instance \{\} \{\nuplevel 1 \{\n"
            if {[info exists ::basique::classes(%NAME%,instvars)]} {
                foreach var $::basique::classes(%NAME%,instvars) {
                    append instance_prelude "variable $var\n"
                }
            }
            append instance_prelude "\}\n\}\n"
            # %NAME% is preprocessed into ::myclass
            # then ::myclass body's namespace is mapped into the instance namespace
            set body [string map [list [string trim %NAME% :]:: \
                    [string trim $instance :]::] $::basique::classes(%NAME%)]
            namespace eval $instance $instance_prelude
            namespace eval $instance $body
            # builds the instance
            #puts before
            if {[info exists ::basique::classes(%NAME%,instcompinit)]} {
                # initscript at instance level
                namespace eval %NAME% $::basique::classes(%NAME%,instcompinit)
            }
            uplevel 1 [linsert $args 0 ${instance}::__init__]
            #puts after
            proc $instance {command args} [string map [list %OBJ% $instance] {
                if {$command eq {destroy}} {
                    %OBJ%::__destroy__
                    if {[info exists ::basique::classes(%NAME%,instcompdestroy)]} {
                        # destroyscript at instance level
                        namespace eval %NAME% $::basique::classes(%NAME%,instcompdestroy)
                    }
                    catch {namespace delete %OBJ%}
                    catch {rename %OBJ% {}}
                    return
                }
                switch -- $command {
                    __init__ - __destroy__ - __classinit__ - __classdestroy__ - common - instance {
                        error {protected command}
                    }
                    default {
                        return [uplevel 1 [linsert $args 0 %OBJ%::$command]]
                    }
                }
            }]
            return $instance
        }]
    }
    
    proc lfilter {var list condition} {
        upvar $var x
        set out {} 
        foreach x $list {
            if {[uplevel 1 expr $condition]} {
                lappend out $x
            }
        }
        return $out
    }
    
    proc autoname {name} {
        variable classes
        if {![info exists classes($name)]} {
            error "class $name not found"
        }
        if {![info exists classes($name,counter)]} {
            set classes($name,counter) 0
        }
        while {[llength [info procs ${name}__$classes($name,counter)]]} {
            incr classes($name,counter)
        }
        return ${name}__$classes($name,counter)
    }
}
package provide basique 1.0

Example

basique::class foo {
    variable name
    proc __init__ {vname} {
        instance
        set name $vname
    }
    proc __destroy__ {} {
        instance
        puts "Goodbye $name !"
    }
}

foo new a Arnold
set [a . name] Meyer
puts [a -> name]
a destroy

Now let's build a singleton handler :

basique::class Foo {
    common instance
    proc __classdestroy__ {} {
        common instance
        $instance destroy
    }
    proc __init__ {} {
        if {[uplevel namespace current] ne {::Foo}} {
            error {cannot instantiate singleton class}
        }
    }
    proc __destroy__ {} {
    }
    proc getInstance {} {
        common instance
        if {![info exists instance]} {
            set instance [::Foo]
        }
        return $instance
    }
}
set inst {}
foreach i {1 2 3} {
    lappend inst [Foo getInstance]
}
puts "singletons : $inst"

ANON: 2006-07-26:

Nice Work!

I wonder how to distinguish those namespaces as classes or instances from any other namespace.

Sarnold 2006-07-29: You really hit the point! Since those classes and objects are instances of namespaces, there is, in theory, no way to distinguish them from ordinary namespaces.

But I can tell you that, to make them more object-like, for every classe and object, a command with the same name as the namespace is created. Indeed we can do :

MyClass cook veryhot

as well as :

MyClass::cook veryhot

And in fact, you are invited to use the "object-like" method for creation and destruction of objects.

So, back to our subject, to test if it is not an ordinary namespace,

proc isobject {name} {llength [info procs MyClass]}
if {[isobject MyClass]} {...}
MyClass a
if {[isobject $a]} {...}

Sarnold 2008-07-14: Updated for Fiction!.

Page Authors

PYK
Cleaned up layout and reworded some things.