Extending TclOO with metaclasses

!! Note !!

An improved implementation of this idea now exists at aspect's tcl-hacks in modules/metaclass-0.tm. Most of the prose below remains relevant, and the mechanism is almost identical, but that implementation is more careful to not leave cruft on metaclass-derived classes.

Overview

metaclass is a concept introduced by TclOO, which is most explicitly visible in the info object command:

  info object isa metaclass ''object''
    This returns whether object is a class that can manufacture classes (i.e. is oo::class or a subclass of it).

So what are they good for? Well, the first thing aspect expected them to help with is extending TclOO, in the sense of adding commands which can be used on object definition scripts.

The reason for extending with metaclasses instead of adding commands to oo::define should become clear on reading TclOO Tricks: what might appear fixed concepts, like classvariable or classmethod, are actually quite loose: in different object systems they can behave quite differently! TclOO is flexible enough to accommodate multiple definitions, but we can't all expect to share a namespace without conflicts. "snit in TclOO" and "XOTcl in TclOO" needs to coexist peacefully. This page is an attempt to show one way that could work.

The code below has been only proven by running it by hand, and Inspecting TclOO to ensure the created objects and classes look correct. It could do with some cleaning up, and will probably need it before anyone other than aspect can run it, but the point is to read it, critique the approach and maybe learn something about TclOO along the way.

Known issues/todos:

  • the tests could be more complete in ensuring metaclass methods don't leak, etc
  • complete coverage of TclOO Tricks in this safer style -- I think this is now sufficient to cover the reasonable items in there which write on oo::define
  • namespace, package and document suitably for inclusion in tcllib, to replace some of the more broken parts of ooutil
  • direct readers of TclOO Tricks to this page, possibly deleting some of the content here
  • justify calling this package SMOP, though it's not really a Simple Meta-Object Protocol
  • add some trivial wrappers of oo::object and oo::class that make life easier and might as well live here

Discussion

dkf - 2014-09-21 17:06:15

The thing I've used metaclasses for so far has been to control construction better. This is particularly relevant when dealing with megawidgets, where the returned name of the instance must be a widget path and must not be fully qualified. Intercepting things so that all works transparently is the sort of thing that is refactorizable into a metaclass (where I also put in code to ensure that the create method name can be omitted, etc).

ak- 2014-10-08 13:23

One place where I would like to use meta-clases is in the stackato command line client. See the public sources @ https://github.com/ActiveState/stackato-cli , and specifically the v2* code under lib/stackato. I.e. base class

    https://github.com/ActiveState/stackato-cli/blob/master/lib/stackato/v2base.tcl

and, for example

    https://github.com/ActiveState/stackato-cli/blob/master/lib/stackato/v2domain.tcl

Currently the attribute configuration of an entity is set up in the instance constructor. I would really like to have this in the class itself instead, with instances just referencing the shared information instead of each having their own copy. Another point is that the classmethod definitions do not seem to fully traverse the class hierarchy. I can see/use them in a sub-class of the base, but not in a sub-class of a sub-class, i.e. 2 levels deep. Having a class-method definition without that bug would be helpful.

aspect- 2014-10-09: This implementation of classmethod appears to behave correctly in the 2nd case (about to add a test to this page). Your Attribute method looks like a good candidate for putting on a metaclass so it can be declared in the class creation script, but my brain's not quite up to engineering a simple example with the right behaviour.

ak- 2014-10-09: An interesting aspect of the 'Attribute' and 'Many' commands is that they create object-level forwards to a regular instance method to implement access to the attributes, i.e. an 'Attribute foo' defines a forward @foo in the object which resolves to 'my Access foo ...', so that later I can [$obj @foo do-this-and-that]. This should be workable in a meta-class setup as well, I believe.

Code

# helper procs which belong in their own package:

    # aka [range].  Args are actually {{x 0} y+1}
    proc iota {a {b ""}} {
        if {$b eq ""} {
            set b $a
            set a 0
        }
        for {set r {}} {$a<$b} {incr a} {
            lappend r $a
        }
        return $r
    }

    # this is generally useful.
    # with multiple arguments it is equivalent to:
    #   [concat {*}[lmap ...]]
    # which under some circumstances can be thought of as:
    #   [join [lmap ...] " "]
    # the pattern comes up a lot.
    # Alternative names:  [lconcat] [ljoin] [lmap*]
    #
    proc lconcat args {
        concat {*}[uplevel 1 lmap $args]
    }

    # normal map, but does multiple arguments:
    #  % map {expr} {1 2 3} {+ - *} {2 4 5}
    #  {3 -2 15}
    #
    proc map {cmdPrefix args} {
        set names [iota [llength $args]]
        set forArgs [lconcat n $names a $args {list $n $a}]
        set cmdArgs [lconcat name $names {string cat \$ $name}]
        set body "$cmdPrefix $cmdArgs"
        set body "uplevel 1 \[list $body\]"
        lmap {*}$forArgs $body
    }

# a metaclass is a place for defining additional "class definition" methods, in addition
# to those normally available via oo::define.
#
oo::class create metaclass {
    superclass oo::class
    constructor {args} {
        if {[info object class [self]] eq [self class]} {
            ;# only if we're defining a metaclass:
            oo::define [self] superclass [self class]
        } else {
            ;# but not if we're defining an instance:
        }

        set myns [self namespace]::ns   ;# namespace for evaluating creation script
                                        ;# to which all our methods are aliased:
        foreach cmd [info object methods [self] -all] {
            if {$cmd ni {new create destroy}} { ;# object and class methods don't count
                interp alias {} ${myns}::$cmd {} [self] $cmd
            }
        }
        tailcall namespace eval $myns {*}$args  ;# in lieu of [next]
        ;#namespace eval $myns {*}$args
        ;#rename ${myns}::self {}
    }
}

;# wrap all the oo::define commands as methods on the class:
foreach cmd [map {namespace tail} [info commands ::oo::define::*]] {
    oo::define metaclass method $cmd args "
        oo::define \[self\] $cmd {*}\$args
    "
}

Class Variables

#   classvariable defines a variable that lives on the class object, and is 
#   linked via [namespace upvar]ed as an object variable into each instance's
#   namespace on creation.
#
# It is the equivalent of:
#   oo::class create Cnted {
#     variable n    ;# makes n visible in methods
#     variable x
#     constructor {} {
#        my eval namespace upvar [info object namespace [self class]] n n
#        incr n
#        set x $n
#     }
#     method who {} {
#        return "I am $n of $x"
#     }
#   }

    metaclass create ClassyVars {
        variable Classvars
        constructor args {
            set Classvars {}
            next {*}$args
            oo::define [self] mixin -append [ClassyVarMixin new $Classvars]
        }
        method classvariable {name} {
            lappend Classvars $name
            uplevel 1 [list variable $name]
        }
    }

# to achieve this we use a "dynamic mixin".  This is just a way to create a mixin with a
# parameter:  in this case, ClassyVarMixin takes a list of (unqualified) variable names
# as a parameter, and creates an instance whose constructor links those variables to the
# class.

;# FIXME: hypnotoad wasn't very keen on this, though he acknowledged it requires less code than his sqlite-backed interps.
;# FIXME: hypnotoad's suggestion:  move the constructor into a common Initialize method
    oo::class create ClassyVarMixin {
        superclass oo::class
        constructor {classvars} {
            set vars [lmap v $classvars {list $v $v}]
            set vars [concat {*}$vars]
            oo::define [self] constructor {args} [format {
                set cls [info object class [self]]  ;# our actual class, for putting the var in
                set cns [info object namespace $cls]
                oo::objdefine $cls variable %2$s
                my eval namespace upvar $cns %1$s
                next {*}$args
            } $vars $classvars]
        }
    }

Test

tcltest::test classvariable-1.1 "Basic classvariable test" -body {
    ClassyVars create Counted {
        classvariable n
        variable x
        constructor args {
            set x [incr n]
            # note: no [next]!
        }
        method who {} {
            list $x of $n
        }
        destructor {
            incr n -1
        }
    }
    concat [lmap o {a b c} {
        Counted create $o
        $o who
    }] [lmap o {a b c} {
        $o who
    }] [lmap o {a b c} {
        apply {{x args} {set x}} [$o who] [$o destroy]
    }] [rename Counted {}]
} -result {{1 of 1} {2 of 2} {3 of 3} {1 of 3} {2 of 3} {3 of 3} {1 of 3} {2 of 2} {3 of 1}}

Class Methods

# a classmethod (Ruby-like version) is a method that can be called on a class,
# and on subclasses of that class, but not on their instances
#
# The simplest way to put a method on a class is like this:
#  oo::class create Foo {
#    self method bar {} {}
#  }
#
# Or:
#  oo::class create Foo {}
#  oo::objdefine Foo bar {} {}
#
# Both of which permit:
#  Foo bar
#
# But to get on the superclass inheritance chain, it needs to be a class method on Foo's class.
# We fake this by creating a paralell inheritance hierarchy of metaclasses, which is easier to
# explain in code:

    metaclass create ClassyMethods {
        variable Classmethods
        constructor args {
            uplevel 1 [format {
                oo::class create %1$s.Class {
                    superclass oo::class
                }
            } [list [self]]]
            next {*}$args
            oo::objdefine [self] class [self].Class
        }
        method classmethod {name args body} {
            tailcall oo::define [self].Class method $name $args $body
        }
        method superclass {class} {
            #debug do oo::objdefine [self] mixin -append $class
            tailcall oo::define [self].Class superclass ${class}.Class
        }
    }

Test

tcltest::test classmethod-1.1 "Basic classmethod test" -body {
    ;# we want to start with this definition:
    ClassyMethods create ActiveRecord {
        classmethod find args {
            list [self] finding {*}$args
        }
    }

    ClassyMethods create Table {
        superclass ActiveRecord
    }

    ClassyMethods create ConcreteTable {
        superclass Table
    }

    list [Table find] [ConcreteTable find]
} -result {{::Table finding} {::ConcreteTable finding}}

# the above definition expands to something like the following:
#  ClassyMethods create ActiveRecord.Class {
#      method find args {
#          list [self] finding {*}$args
#      }
#  }
#  ClassyMethods create ActiveRecord {
#      class ActiveRecord.Class
#  }
#  
#  ClassyMethods create Table.Class {
#      superclass ActiveRecord
#  }
#  ClassyMethods create Table {
#      superclass Table.Class
#  }

Private Methods

# This one is pretty simple.

metaclass create PrivacyConcious {
    method private {method name args} {
        ;# FIXME: this is not robust against other things we might want to make private, like forwards?
        if {$method ne "method"} {return -code error "must be: private method <name> <args> <body>"}
        uplevel 1 [list $method $name {*}$args]
        uplevel 1 [list unexport $name]
    }
}

Test

tcltest::test privatemethod-1.1 "Basic private method test" -body {
    PrivacyConcious create Pc {
        private method foo {} {
            list [self class] [self object]
        }
        method bar {} {
            my foo
        }
    }
    Pc create pc

    list [pc bar] [catch {
        pc foo
    } e o] $e [dict get $o -errorcode]
} -result {{::Pc ::pc} 1 {unknown method "foo": must be bar or destroy} {TCL LOOKUP METHOD foo}}

Abstract Methods

THIS IS BROKEN -- it started life as a proof-of-concept for a random question in the Tcl'ers chat. aspect is not alone in thinking the concept is a bit foreign to Tcl, so I'm not going to fix it, though somebody else may like to.

## Doesn't work!
    oo::class create AbstractMixin {
        superclass oo::class
        constructor {abstractmethods} {
            oo::define [self] constructor {args} [format {
debug log {Consing AbstractMixinstance [self] [self class] [info object class [self]]}
                next   {*}$args
                set mymethods [info class methods [self] -all]
                foreach m %1$s {
                    if {$m ni $mymethods} {
                        throw {CLASS ABSTRACTMETHOD} "abstract method $m not provided in [self]!"
                    }
                }
            } [list $abstractmethods]]
        }
    }

    metaclass create AbstractBase {
        variable Abstractmethods
        constructor args {
            set Abstractmethods {}
            next {*}$args
            oo::define [self] mixin -append [AbstractMixin new $Abstractmethods]
        }
        method abstractmethod {name} {
            lappend Abstractmethods $name
        }
    }

Test

## Doesn't work!
tcltest::test abstractmethod-1.1 "Basic abstractmethod test" -body {
    # things that look like read/write channels:
    AbstractBase create Channish {
        constructor args {
            puts "Making a Channish called [self]"
            #next   {*}$args
        }
        abstractmethod read
        abstractmethod write
        # method, constructor, etc
    }

    Channish create Try {
        method read {args} {}
        method write {} {}
    }

    list [catch {
        Channish create Try2 {
            method read {args} {}
        }
    } e o] $e [dict get $o -errorcode]
} -result {1 {abstract method write not provided in ::Try2!} {CLASS ABSTRACTMETHOD}}

Mixing it Up

The goal of this exercise is to allow everyone to contribute metaclasses, so that they can be mixed and matched together freely. The suggested use should be for a programmer to create their own base metaclass, importing only the extensions that they want as mixins.

Note that there are some flaws in this particular implementation: notably, classmethods do not automatically see classvariables, as a reasonable programmer might expect. Solving this requires making deeper decisions about what a classmethod actually is and tighter integration between the components, which is not the goal here.

tcltest::test smop-mixin-1.1 "Testing mixin composition" -body {
    metaclass create Class {
        mixin -append ClassyVars PrivacyConcious ClassyMethods
    }

    Class create Wop {
        classvariable n
        variable x
        constructor args {
            set x [incr n]
        }
        method who {} {
            list $x of $n
        }
        private method woo {} {}
        classmethod what {} {
            variable n  ;# because classvariable knows not of classmethod, and v-v
                        ;# and classmethods actually live on class.Class
            list we be $n
        }
    }
    Wop create who
    Wop create woo
    list [who who] [woo who] [Wop what]
} -result {{1 of 2} {2 of 2} {we be 2}}

Abstract Class

DKF: This is a somewhat different way to do the abstraction.

oo::class create ::class {
    superclass oo::class
    self method create {name args} {
        set instance [next $name {*}$args]
        oo::define $instance superclass -append [self]
        return $instance
    }
    method new args {
        my <VERIFY.CONCRETE>
        next {*}$args
    }
    method create {name args} {
        my <VERIFY.CONCRETE>
        next $name {*}$args
    }

    method <VERIFY.CONCRETE> {} {
        foreach m [info class methods [self] -all] {
            set call [lindex [info class call [self] $m] 0]
            if {[lindex $call 0] eq "method" && [lindex $call 3] eq "method"} {
                set cls [lindex $call 2]
                set body [lindex [info class definition $cls $m] 1]
                if {$body eq "abstract"} {
                    return -code error -level 2 \
                        -errorcode {CLASS ABSTRACTMETHOD} \
                        "[self] is abstract (method \"$m\")"
                }
            }
        }
    }
}

To mark a method as abstract (which inhibits the class from being instantiated without an override being supplied), just make the body of the method be abstract:

    method foobar {x y args} abstract

Using it (test/example highly derived from elsewhere on this page):

package require tcltest

tcltest::test abstractmethod-1.1 "Basic abstractmethod test" -body {
    # things that look like read/write channels:
    class create Channish {
        constructor args {
            puts "Making a Channish called [self]"
            #next   {*}$args
        }
        method read args abstract
        method write {} abstract
        # method, constructor, etc
    }

    class create Try {
        superclass Channish
        method read {args} {}
        method write {} {}
    }

    list [catch {
        Try new
        Channish new
    } e o] $e [dict get $o -errorcode]
} -result {1 {::Channish is abstract (method "read")} {CLASS ABSTRACTMETHOD}}

tcltest::cleanupTests

Garbage Collection (sort of)

Available as a package at github: gc_class

oo::class create ::gc_class {
    superclass ::oo::class

    method instvar {varname args} {
        upvar 1 $varname scopevar
        if {[array exists scopevar]} {
            error "Can't use $varname for the instance variable: it exists and is an array"
        }
        # Chain to [new] using an uplevel to preserve the relative callframe context vs [new] and [create]
        set scopevar [uplevel 1 [list [namespace origin my] new {*}$args]]
        set fqobj [namespace origin $scopevar] 
        trace add variable scopevar {write unset} [list [namespace origin my] _gc $fqobj]
        return ""
    }

    method _gc {fqobj name1 name2 op} { 
        upvar 1 $name1 scopevar
        if {[info object isa object $fqobj]} { $fqobj destroy }
        trace remove variable scopevar {write unset} [list [namespace origin my] _gc $fqobj]
    }

    # Uncomment this to prevent the [new] and [create] methods
    #unexport create new
}

gc_class create Foo {
    variable thing

    constructor {a_thing} {
        set thing   $a_thing
    }

    method greet {} {
        puts "hello, $thing"
    }
}

proc bar {} {
    Foo instvar foo1 "first example"
    $foo1 greet     ;# says "hello, first example"

    Foo instvar foo2 "second example"
    $foo2 greet     ;# says "hello, second example"

    Foo instvar foo2 "third example"    ;# second example dies here
    $foo2 greet     ;# says "hello, third example"

    Foo instvar foo4 "fourth example"
    $foo4 greet     ;# says "hello, fourth example"

    set foo2    "something else"    ;# third example dies here

    unset foo4      ;# fourth example dies here

    Foo instvar ::foo5 "fifth example"

    # first example dies when the proc returns here (since $foo1 goes out of scope)
}

bar

# One Foo instance remains, the "fifth example"

$foo5 greet     ;# says "hello, fifth example"
unset foo5      ;# fifth example dies here

# No instances of Foo remain

DKF: Tcl 8.7 will have some extra features to make advanced stuff easier. The one which I've got in officially is enhancing the self in declarations so that it can report the class or object being configured. Here's a simple example that makes it easier to put procedures in an object's namespace from outside:

proc oo::objdefine::proc {name arguments body} {
    # This is the magical bit
    set obj [uplevel 1 {
        self
    }]
    set ns [info object namespace $obj]
    tailcall ::proc ${ns}::$name $arguments $body
}

With that, you can then do this:

oo::class create Foo {
    self {
        proc hi {} {
            puts "hi there from Foo"
        }
        method boo {} {
            puts "start of boo"
            hi
            puts "end of boo"
        }
    }
}

Foo boo

I've also got an experimental branch, dkf-oo-override-definition-namespaces, that lets you override what namespace is used to drive the guts of oo::define for particular class, and of oo::objdefine for a particular object. The aim is that this lets people write their own definition languages for a class much more easily; the infrastructure will transparently transfer control to your language rather than the standard one.