Basique - OO-like namespaces

Sarnold thinks that classes should look - as possible as they can - like namespaces, because it is the current encapsulation model. It may be extreme, but some developers may want to convert quickly a namespace in a Class or Megawidget - while the opposite cannot 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 instanciate 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]} {...}

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