# coclass.tcl - classes which are also coros

namespace eval tcl::unsupported namespace export yieldm
namespace import tcl::unsupported::yieldm

if {[info commands ::oo::define::classmethod] eq ""} {
    proc ::oo::define::classmethod {name {args {}} {body {}}} {
        set class [lindex [info level -1] 1]
        set classmy [info object namespace $class]::my
        if {[llength [info level 0]] == 4} {
            uplevel 1 [list self method $name $args $body]
        }
        uplevel 1 [list forward $name $classmy $name]
    }
}

oo::class create oo::coclass {
    # objgone - the object has died - kill the coro too
    classmethod objgone {obj coro} {
        trace delete command $coro delete [list ::oo::coclass corogone $obj $coro]
        rename $coro {}
    }

    # corogone - the coro has gone - restart it if the object is still there.
    classmethod corogone {obj coro} {
        if {[info commands $obj] ne ""} {
            # (re)create a coro attachment to $obj
            coroutine $coro $obj __dispatch__        ;# create our coro with the object's name
            trace add command $coro delete [list ::oo::coclass corogone $obj $coro]
        } else {
            # both the object and the coro have gone.
        }
    }

    # intervene - add a __dispatch__ method to the object
    # __dispatch__ shims between the fake object (coro) and the actual object.
    method intervene {obj} {
        rename $obj ${obj}_        ;# move the object out of the way
        trace add command ${obj}_ delete [list ::oo::coclass::objgone ${obj}_ $obj]
        my corogone ${obj}_ $obj
        return $obj
    }

    # new - create a new instance of this class,
    # shimmed so it's actually being invoked as a coro
    method new {args} {
        tailcall my intervene [next {*}$args]
    }

    # new - create a new instance of this class,
    # shimmed so it's actually being invoked as a coro
    method create {name args} {
        tailcall my intervene [next $name {*}$args]
    }

    superclass ::oo::class
    constructor {args} {
        next {*}$args

        # add a __dispatch__ method to the class to shim between coro interface and object instance
        oo::define [self] {
            method __dispatch__ {} {
                set self [info coroutine]        ;# this is the coroutine
                set obj [self]                        ;# the original obj being forwarded to

                set result {}                ;# method invocation result
                catch {
                    while {1} {
                        set result [my {*}[::yieldm $result]]        ;# invoke whatever's passed in
                    }
                } e eo

                # The method invocation errored
                # this will kill the coro if we return it, but it must be returned to caller
                # So we must make another identically named coro and then return the error
                # from this inevitably doomed coro.
                rename $self ${self}_dead_
                if {[catch {::oo::coclass corogone $obj $self} e1 eo1]} {
                    # we failed to make the replacement coro - here's why
                    puts stderr "corogone fail: $e1 ($eo1)"
                }

                return -options $eo $e        ;# return the error result to the caller
                # this instance of the coro goes away now
            }
            export __dispatch__
        }

        return [self]
    }
}

oo::coclass create Fred {
    method Var {var} {
        variable $var
        return [set $var]
    }
    method error {} {
        error "ERROR"
    }

    constructor {args} {
        variable {*}$args
    }
}

if {1} {
    set fred [Fred new a 1 b 2 c 3]
    puts [$fred Var a]
    if {[catch {$fred error}]} {
        puts stderr "CAUGHT"
    }
    puts [$fred Var b]
    $fred destroy
}