Proposed object system for Jim Tcl

objects.tcl

# ---------------------------------------------------------------------------
# Models - A flexible object system for Jim
# ---------------------------------------------------------------------------

# XXX Observation after writing all the code below: [ref]erences are _not_
# used to store things. They are only used to invoke finalizers.

# ---------------------------------------------------------------------------
# Stubs
# ---------------------------------------------------------------------------

package require ensemble

# Pure-Tcl stub for statics (limited, no destruction).
#
# The idea is that every /command/ (not just every procedure) has a separate
# variable scope attached to it, with its lifetime controlled by the owner.
# Static variables fit into this model as a special case.

proc procvar {procName args} {
    foreach {otherVar myVar} $args {
        uplevel 1 [list upvar #0 $procName#$otherVar $myVar]
    }
}

proc {info statics} {procName} {
    set names {}
    foreach longName [info globals $procName#*] {
        lappend names [string range $longName [string length $procName]+1 end]
    }
    set names
}

# Simplified version similar to [global]. XXX Not completely similar:
# [lindex [info level -1] 0] instead of $proc. But this version is more
# useful.
proc static {proc args} {
    foreach varName $args {
        lappend argList $varName $varName
    }
    uplevel 1 [list procvar $proc] {*}$argList
}

# XXX Set operations.

proc lintersect {list args} {
    set dicts [lmap otherList $args {
        set dict {}
        foreach item $otherList {
            lappend dict $item {}
        }
        set dict
    }]

    lmap item $list {
        set ok 1
        foreach dict $dicts {
            if {![dict exists $dict $item]} {set ok 0; break}
        }
        if {$ok} then {set item} else continue
    }
}

# ---------------------------------------------------------------------------
# Core
# ---------------------------------------------------------------------------
# XXX These are somewhat primitive, but I don't know whether I should put
# them in a namespace (or use qualified names).

proc slot {name value} {
    proc $name {self args} {value} {
        set value {*}$args
    }
}

proc handle {name} {
    if {$name eq "#auto"} {
        set name [ref {} handle]
        finalize $name handle.destroy
    }

    ensemble $name: self
    # XXX GC *never* finds our objects because the line below introduces
    # a circular reference. Bummer. =(
    alias $name $name: $name

    alias [concat $name: unknown] handle.unknown $name
    # XXX Attention: prototype and mask can't be normal instance variables
    # because they should not be inherited.
    slot [concat $name: prototype] {}
    slot [concat $name: protomask] {}

    set name
}

proc handle.destroy {name contents} {
    rename $name ""
    rename $name: ""
}

proc handle.unknown {name self selector args} {
    set prototype [$name: $self prototype]
    set prototypeMask [$name: $self protomask]
    if {$prototype eq "" || $selector in $prototypeMask} {
        return -code error "invalid command name \"$name $selector\""
    }

    alias [concat $name: $selector] $prototype: .. $selector
    tailcall [concat $name: $selector] $self {*}$args
}

# ---------------------------------------------------------------------------
# Objects
# ---------------------------------------------------------------------------

# XXX Got sick of trying to invent a clever name. [models] is supposed to be
# a namespace for model objects like Self's traits.
ensemble models

handle {models object}

proc {models object: clone} {self {name #auto}} {
    set name [handle $name]
    $name prototype $self
    foreach varName [{info statics} $self] {
        procvar $self $varName source
        procvar $name $varName target
        set target $source
    }
    return $name
}

# No helper methods ([proc] or [set] or ...) here. This is intentional.

# ---------------------------------------------------------------------------
# Components
# ---------------------------------------------------------------------------
# As in Snit.

if 0 {
# XXX Turns out to be more complex than I thought. <Explain the problem>

proc {object: ensemble} {self name argList} {
    ensemble [concat $self $name:]
    alias [concat $self: $name] [concat $self $name:]
}
}

# ---------------------------------------------------------------------------
# Multimethods
# ---------------------------------------------------------------------------
# Prototype-based multiple dispatch, like Slate or Cecil.

proc multi {args} {
    if {[llength $args] == 0} {
        return -code error "wrong # args: should be \"multi word ...\""
    }

    foreach part [lrange $args 0 end-1] {
        lappend path $part
        if {![exists -command $path]} {ensemble $path arg}
    }
    alias $args multi.dispatch $args

    foreach part $args {
        lappend spec $part {models object}
    }
    # XXX [curry] should be using the optimized [alias].
    method {*}$spec [curry multi.unknown $args]
}

# XXX Hmm, a good candidate for a C implementation.
proc multi.dispatch {sels args} {
    if {[llength $args] < [llength $sels]} {
        return -code error "wrong # args: not enough object arguments to \"$sels\""
    }
    set objs [lrange $args 0 [llength $sels]-1]

    # Calculate the set of all reachable methods

    set selector [join $sels _]_
    for {set i 0} {$i < [llength $objs]} {incr i} {
        set ms [[lindex $objs $i] $selector $i]
        lappend methods [join $ms]

        set ord {}; set rank 0
        foreach mlist $ms {
            foreach method $mlist {set ord($method) $rank}
            incr rank
        }
        lappend ordering $ord
    }

    # Find and rank the applicable ones

    set candidates [lintersect {*}$methods]
    if {[llength $candidates] == 0} {
        # This is a failure harder than multi.unknown.
        return -code error "no candidates for multi call \"$call\""
    }

    set ranks [lmap cand $candidates {
        lmap ord $ordering {
            set ord($cand)
        }
    }]

    # Find the winning method

    set maxCand [lindex $candidates 0]
    set maxRank [lindex $ranks 0]
    foreach cand $candidates rank $ranks {
        set replace 1
        foreach r $rank s $maxRank {
            if {$r < $s} {set replace 0; break}
        }
        if {$replace} {
            set maxCand $cand
            set maxRank $rank
        }
    }

    # Check for conflicts (XXX this doesn't check for methods with identical
    # ranks)

    set conflict 0
    foreach rank $ranks {
        foreach r $rank s $maxRank {
            if {$r > $s} {set conflict 1; break}
        }
        if {$conflict} {
            foreach sel $sels obj $objs {lappend call $sel $obj}
            return -code error "ambiguous multi call \"$call\""
        }
    }

    # Call the winning method

    tailcall $maxCand {*}$args
}

proc multi.unknown {sels args} {
    foreach selector $sels object [lrange $args 0 [llength $sels]] {
        lappend call $selector $object 
    }
    return -code error "invalid multi call \"$call\""
}

proc method {args proc} {
    foreach {part object} $args {
        append selector ${part}_
    }
    set position 0
    foreach {part object} $args {
        set procName [concat $object: $selector]
        if {![exists -command $procName]} {
            # XXX Update this as soon as statics become real.
            proc $procName {self position} {object selector} {
                static [concat $object: $selector] methods
                set prototype [$object: $self prototype]
                if {$prototype ne ""} {
                    set mro [$prototype: $self $selector $position]
                }
                lappend mro [lindex $methods $position]
            }
        }

        static $procName methods
        lappend methods
        if {[llength $methods] <= $position} {
            lappend methods {*}[lrepeat [- $position [llength $methods] -1] {}]
        }
        set ms [lindex $methods $position]
        lappend ms $proc
        lset methods $position $ms
        incr position
    }
}

proc mproc {args} {
    if {[llength $args] % 2 == 0} {
        set signature [lrange $args 0 end-2]
        set defnArgs [lrange $args end-1 end]
    } else {
        set signature [lrange $args 0 end-3]
        set defnArgs [lrange $args end-2 end]
    }

    method {*}$signature [lambda {*}$defnArgs]
}

# ---------------------------------------------------------------------------
# Traits
# ---------------------------------------------------------------------------
# This is a mechanism for combining functionality orthogonal to cloning. See
# http://c2.com/cgi-bin/wiki?TraitsPaper.

ensemble traits
models object clone {traits blank}

proc abstract {name self args} {
    return -code error "abstract procedure \"$self $name\" is not implemented"
}

# Storage interface ---------------------------------------------------------

# The "true" way to define a trait proc.
proc {models trait: alias} {self name command args} {
    static $self procs

    set defn [list $command {*}$args]
    if {$name in $procs} {
        set procs($name) $defn
    } else {
        tailcall $self conflict $name $defn
    }
}

proc {models trait: procs} {self} {
    static $self procs
    dict keys procs
}

proc {models trait: body} {self procName} {
    static $self procs
    set procs($procName) 
}

proc {models trait: rename} {self oldName newName} {
    static $self procs

    set defn $procs($oldName)
    unset procs($oldName)
    if {$newName ne ""} {
        $self alias $newName {*}$defn
    }
}

# Composition logic ---------------------------------------------------------

multi add and
# XXX This should have been a symmetric multimethod, but we don't have these.

mproc add {traits blank} and {traits blank} {first second} {
    set sum [traits blank clone]
    foreach procName [$first procs] {
        $sum alias $procName [$first body $procName]
    }
    foreach procName [$second procs] {
        $sum alias $procName [$second body $procName]
    }
}

proc {models trait: conflict} {self procName impl} {
    set myImpl [$self body $procName]

    if {$myImpl eq $impl} {
        # We don't need to do anything
        return
    }

    $self rename $procName ""
    $self alias $procName abstract $procName
}

# Application ---------------------------------------------------------------
# XXX Rewrite this.

proc {traits blank: attach} {self object} {
    if {[exists -command [concat $object: trait]] && 
        [lindex [$object trait] 0] eq $object
    } then {
        [lindex [$object trait] 1] detach $object
    }

    proc [concat $object: trait] {self} {object {trait self}} {
        return [list $object $trait]
    }
    foreach procName [$self procs] {
        alias [concat $object: $procName] [$self body $procName]
    }
}

proc {traits blank: detach} {self object} {
    if {![exists -command [concat $object: trait]] ||
        [$object trait] ne [list $object $self]
    {
        return -code error "cannot detach trait \"$self\": not attached"
    }

    foreach procName [$self procs] {
        rename [concat $object: $procName] ""
    }
}

# Helpers -------------------------------------------------------------------

proc {traits blank: proc} {self name args} { 
    if {[llength $args] == 0 || [llength $args] > 3} {
        return -code error "wrong # args: should be \"$self proc name abstract|args ?statics? body\""
    } elseif {[llength $args] == 1} {
        $self alias $name abstract $name
    } else {
        $self alias $name [lambda {*}$args]
    }
}

proc {traits blank: delete} {self method} {
    $self rename $method ""
}

proc {traits blank: +} {self trait args} {
    set sum [add $self and $trait]
    tailcall $sum {*}$args
}

# ---------------------------------------------------------------------------
# Tests
# ---------------------------------------------------------------------------

models object clone {models box}
proc {models box: set} {self args} {
    static $self value
    if {[llength $args] > 1} {
        return -code error "wrong # args: should be \"box: $self set ?value?\""
    } elseif {[llength $args] == 1} {
        set value [lindex $args 0]
    }
    set value
}

set b [models box clone]
$b set "Hello world!"
puts [$b set]
$b set boo
puts [$b set]


models object clone {models base}
models object clone {models base'}
models base clone {models derived}
models base' clone {models derived'}

multi intersect and
proc putv {args} {puts $args}
method intersect {models base} and {models base} [curry putv {base & base}]
method intersect {models base} and {models derived} [curry putv {base & derived}]
# method intersect {models derived} and {models base} [curry putv {derived & base}]
# method intersect {models derived} and {models derived} [curry putv {derived & derived}]
method intersect {models base} and {models base'} [curry putv {base & base'}]

set x [models derived clone]
set y [models base' clone]
intersect $x and $x foo bar
# intersect $y and $y big bang
intersect $x and $y baz boom