TOOT revisited

NEM 18 Jan 2006 I thought it was about time I revisited TOOT. Since first describing the idea almost two years ago, I've done quite a bit of thinking about the basic concepts and had some useful feedback off a bunch of different people. I've played around with a number of different designs for the basic infrastructure during this time, and bits and pieces can be seen scattered around this wiki. I'm currently working on building an actual release of TOOT as a full-fledged (albeit tiny) object system and functional programming library, complete with classes and methods, stateless objects, lexically-scoped functions and lambdas and a bunch of other goodies. I've also developed some techniques for using TOOT that are more efficient than the original dispatch mechanism which relied too heavily on a trip through the unknown command mechanism. Modern TOOT can make use of the original mechanism, but also a more efficient mechanism based on interp aliases. With this framework in place, object method calls are roughly as efficient as snit. Recoding parts in C could probably achieve performance roughly comparable to incr tcl or XOTcl, but one of the goals of TOOT is simplicity. Ideally, the basic TOOT framework should be small enough to copy+paste into your application if needed, and that is what this page attempts to provide: a bare minimum TOOT with no bells or whistles.

To briefly recap, the central idea of TOOT was to try and unify the benefits of object oriented programming, such as data-driven evaluation (where data "knows" its type and how it can be manipulated) and ad hoc polymorphism (where an operation can be implemented differently for different types) with Tcl's transparent value semantics. We would also like to unify object dispatch with ensemble commands which are common in Tcl. For instance, we wish to be able to choose between either:

    mycommand method $object args...

    $object method args...

TOOT manages this task, but in doing so we must make some compromises, notably losing some features traditionally associated with OO:

We weaken encapsulation: while it is possible to use a TOOT object without concern for its implementation, we opt for a transparent or open "bundling" of objects where the underlying representation is always available;
We banish explicit mutable state in favour of referential transparency and value semantics.

The first of these compromises is a fairly major one. TOOT doesn't entirely give up the principles of encapsulation; it still encourages a style whereby objects are used without concern for their implementation. However, TOOT objects do not hide their implementation, but instead make it transparently available. In return for this weakening, TOOT gives you a few goodies such as simple serialisation (i.e. [puts $tootobj] is all that is required) and compatability with Tcl's weak string-based structural typing rules ("if it looks like a list, then it is a list"). Strong encapsulation can be added back into TOOT by other means (e.g., hiding access to an object behind an opaque handle), but if you really want this, I suggest looking at one of the other excellent OO systems available for Tcl (snit and XOTcl are my favourites).

Losing explicit mutable state may seem like more of a concern to many, but I believe this to actually be one of TOOT's greatest assets. TOOT owes a great deal of its design to ideas from functional programming where it is common to minimise use of explicit state to the point of totally eliminating it (as in Haskell). This is not just some crazy whim of mine to make TOOT stateless, but comes as a direct consequence of making objects obey Tcl's "everything is a string" value semantics: values are immutable and never change. In practice, the way TOOT is designed you can make use of side-effects inside method bodies and can update instance variables of an object in the usual way you would in any proc. However, if you do update any instance variables then you must remember to return the new object ("self") at the end of the method, otherwise all changes will be lost. So, an invocation of an updating method in TOOT looks something like this:

    set newobj [$obj setSomeVar $value]

Here, $newobj is assigned with the new object while $obj remains as it was. As with encapsulation, mutable state can be added back into TOOT by means of explicit references. This is the way things are in ML languages where names are immutable but one of the things they can name are mutable reference cells. I'll demonstrate a simple method of achieving references at the end of this page and the release of TOOT will contain a polished implementation of references. Ideally, though, use of references should be minimised. Again, if you really want to use mutable state then TOOT will offer no advantage over other object systems.

Without further ado, we will define the code. I make extensive use of dicts in the code below, and a couple of other 8.5 features. Probably it would not be too much effort to back-port to 8.4 or 8.3. The version of TOOT below has simple classes and objects, with no inheritance or other features.

 # toot.tcl --
 #
 #       TOOT: Transparent Object Oriented Tcl.
 #
 # Copyright (c) 2006 by Neil Madden (nem@cs.nott.ac.uk)
 #
 # License: http://www.cs.nott.ac.uk/~nem/license.terms

 package require Tcl         8.5

 namespace eval ::toot {
     variable VERSION        0.4

     # class name body --
     #
     #      Defines a new class (namespace).
     #
     proc class {name body} {
         set name [resolve 1 $name]
         namespace eval $name [list namespace path [namespace current]]
         namespace eval $name $body
         namespace eval $name {
             namespace export {[a-z]*}
             namespace ensemble create
         }
         define $name: = [resolve dispatch] $name
         return $name
     }

     # define name ?= cmd args...? --
     #
     #      Defines a new command name in the current environment.
     #
     proc define {name args} {
         set name [resolve 1 $name]
         if {[llength $args] == 0} {
             # Introspection
             interp alias {} $name
         } else {
             set args [lassign $args = cmd]
             if {[set =] ne "="} {
                 set cmd "[lindex [info level 0] 0] ?= cmd args..?"
                 return -code error "invalid syntax: should be \"$cmd\""
             }
             interp alias {} $name {} {expand}$cmd {expand}$args
         }
     }

     # dispatch class self args ... --
     #
     #      Interprets $args as a message to object $self of class $class.
     #
     proc dispatch {class self args} {
         if {[llength $args] == 0} {
             return $self
         } else {
             set args [lassign $args method]
             uplevel 1 [linsert $args 0 ${class}::$method $self]
         }
     }

     # invoke cmd args...
     #
     #      Invoke a command (list) passing any arguments given.
     #
     proc invoke {cmd args} { uplevel 1 $cmd $args }

     # method name params body --
     #
     #      Define a method for a class.
     #
     proc method {name params body} {
         set body [format { dict with self %s } [list $body]]
         uplevel 1 [list proc $name [linsert $params 0 self] $body]
     }

     # constructor params body --
     #
     #      Define a constructor for a class.
     #
     proc constructor {params body} {
         set class [uplevel 1 { namespace current }]
         set map [dict create %c [list $class] %b $body]
         uplevel 1 [list proc create $params [string map $map {
             set self [dict create class %c]
             %b
             return [list %c: $self]
         }]]
     }

     # resolve ?level? name --
     #
     #      Returns the fully-qualified name of $name resolved relative to
     #      $level on the current call stack.
     #
     proc resolve args {
         if {[llength $args] < 1 || [llength $args] > 2} {
             wrongargs "?level? name"
         }
         if {[llength $args] == 2} {
             lassign $args level name
         } else {
             lassign $args name
             set level 0
         }
         incr level
         if {![string match ::* $name]} {
             set ns [uplevel $level { namespace current }]
             if {$ns eq "::"} {
                 set name ::$name
             } else {
                 set name ${ns}::$name
             }
         }
         return $name
     }

     # wrongargs msg --
     #
     #      Convenience function, similar to Tcl_WrongNumArgs in C.
     #
     proc wrongargs msg {
         set cmd [lindex [info level -1] 0]
         return -code error -level 2 -errorcode WRONGARGS \
             "wrong # args: should be \"$cmd $msg\""
     }

     # self key ?= value? --
     #
     #      Access to instance variables of an object.
     #
     proc self {key args} {
         upvar 1 self self
         if {[llength $args] == 0} {
             return [dict get $self $key]
         }
         set args [lassign $args method]
         eval [linsert $args 0 self:$method $key]
     }
     proc self:= {key value} {
         upvar 1 self self
         dict set self $key $value
     }
     # func ?name? params body --
     #
     #      Creates a lexically scoped function, which captures the
     #      environment of its definition. If no name is given, then it
     #      returns an anonymous function (lambda).
     #
     proc func args {
         if {[llength $args] < 2 || [llength $args] > 3} {
             wrongargs "?name? params body"
         }
         set env [uplevel 1 { capture }]
         if {[llength $args] == 2} {
             lassign $args params body
             return [list [resolve func:] $params $body $env]
         } else {
             lassign $args name params body
             set body [format {
                 set __env__ [dict create %s]
                 dict with __env__ %s
             } [list $env] [list $body]]
             uplevel 1 [list proc $name $params $body]
             return $name
         }
     }

     # func: params body env args... --
     #
     #      Evaluates an anonymous function in the given environment.
     #
     proc func: {params body env args} {
         with [extend $env $params $args] $body
     }

     # extend env names values --
     #
     #      Extend an environment dictionary with the given names and values.
     #
     proc extend {env names values} {
         foreach n $names v $values { dict set env $n $v }
         return $env
     }

     # with env body --
     #
     #      Evaluate $body in the context of $env. A side-effect free version
     #      of [dict with].
     #
     proc with {__env__ __body__} { dict with __env__ $__body__ }

     # capture --
     #
     #      Captures the local variable definitions of its caller and returns
     #      them as an environment.
     #
     proc capture {} {
         set env [dict create]
         foreach name [uplevel 1 { info locals }] {
             upvar 1 $name var
             catch { dict set env $name $var }
         }
         return $env
     }

     # Export TOOT commands
     namespace export {[a-z]*}
     namespace ensemble create
     package provide [namespace tail [namespace current]] $VERSION
 }

The version of TOOT given above is minimal, but lacks a number of features such as inheritance, traits, pattern matching (which will be based on named constructors), and more sophisticated dispatch through self (the version above is limited to accessing instance variables). The full release of TOOT will contain all these features, and a few more. However, even with this relatively simple TOOT we can demonstrate the basics of TOOT-style OO programming:

 namespace path ::toot

 class List {
     constructor args {
         self data = $args
     }
     method index  idx  { lindex $data $idx }
     method append item { lappend data $item }
     method length {}   { llength $data }
     # See http://wiki.tcl.tk/15271
     method enumerate {proc seed} {
         foreach item $data {
            set seed [invoke $proc $seed $item]
         }
         return $seed
     }
 }
 class Dict {
     constructor args {
         set self $args
     }
     method get key { self $key }
     method keys {} { dict keys $self }
     method values {} { dict values $self }
     method enumerate {proc seed} {
         dict for {key value} $self {
             set seed [invoke $proc $seed [list $key $value]]
         }
         return $seed
     }
 }
 proc map {proc collection} {
     $collection enumerate [list map-helper $proc] [list]
 }
 proc map-helper {proc accum item} {
     lappend accum [invoke $proc $item]
 }
 define xs = [List create 1 2 3 4 5 6 7 8 9 10]
 define squares = map [func x { expr {$x * $x} }]
 puts "squares = [squares xs]"
 define capitals = [Dict create France Paris UK London USA "Washington DC"]
 map [func item {
     lassign $item country capital
     puts "The capital of $country is $capital"
 }] capitals
 class File {
    constructor filename {
        self name = $filename
    }
    method size {} { file size $name }
    method nativename {} { file nativename $name }
    method enumerate {proc seed} {
        set fd [open $name]
        foreach line [split [read $fd] \n] {
            set seed [invoke $proc $seed $line]
        }
        close $fd
        return $seed
    }
 }
 define toot = [File create toot.tcl]
 puts "toot is [toot enumerate [func {count line} { incr count }] -1] lines"

Well, hope you enjoy the new version. Work permitting, I intend to make a full release of TOOT in the next few weeks.

[ Category Object Orientation | Category Package | TOOT ]