package require Tcl     8.6
package provide actor   0.1

namespace eval ::actor {
    namespace export {[a-z]*}
    namespace ensemble create

    proc create {name} {
        # An actor consists of two parts: a core namespace ensemble (object)
        # that dispatches messages to methods that handle them; and an external
        # actor interface which handles messages from other actors. Messages
        # from other actors are always asynchronous, using the event loop and
        # coroutines.
        
        # Ensure $name is fully-qualified
        set name [qualify 1 $name]

        # Use the naming convention: $name is the actor interface, $name.self is
        # the internal ensemble
        namespace ensemble create -command $name.self -map {}
        slot $name slot     = ::actor slot $name
        slot $name slots    = ::actor slots $name
        slot $name method   = ::actor method $name

        # Create the message dispatcher coroutine
        coroutine $name ::actor dispatch $name.self

        # Rename and install a send interface
        rename $name $name.coro
        interp alias {} $name {} ::actor send $name

        return $name
    }

    proc slot {actor slot = cmd args} {
        set actor [uplevel 1 [list namespace which -command $actor.self]]
        set slots [namespace ensemble configure $actor -map]
        dict set slots $slot [list {*}$cmd {*}$args]
        namespace ensemble configure $actor -map $slots
        return $slot
    }

    proc slots {actor {pattern *}} {
        set actor [uplevel 1 [list namespace which -command $actor.self]]
        set slots [namespace ensemble configure $actor -map]
        return [dict keys $slots $pattern]
    }

    proc method {actor name params body} {
        slot $actor $name = ::apply [list $params $body ::]
    }
    
    proc send {actor args} {
        # Schedule the message to be delivered using the event loop
        after 0 [list ::actor deliver [info coroutine] $actor.coro $args]
        # Then yield and wait for the reply
       # puts "About to yield:"
       # foreach event [after info] { puts "\t$event: [after info $event]" }
        lassign [yield] result options
       # puts "Returning: $result $options"
        return -options $options $result
    }

    proc deliver {from to message} {
        set result [$to $message]
        $from $result
    }

    proc self args {
        set coro [info coroutine]
        regexp {^(.*)\.coro$} $coro -> coro
        set self $coro.self
        tailcall $self {*}$args
    }

    proc dispatch actor {
        set result ""
        set options [dict create]
        while 1 {

            # Yield the result of this message, and receive the next
            set message [yield [list $result $options]]

            #puts "Dispatching: $message"

            # Dispatch the message to the actor ensemble
            catch { $actor {*}$message } result options
        }
    }

    # qualify level name
    #
    #       Returns the fully-qualified version of $name. This is done by
    #       prefixing the name given with the namespace that is current at
    #       $level. In contrast to [namespace which], this command is intended
    #       to be used for commands that have not yet been created.
    #
    proc qualify {level name} {
        if {[string match ::* $name]} { return $name }
        if {[string is integer -strict $level] && $level >= 0} { incr level }
        set ns [uplevel $level { namespace current }]
        if {$ns eq "::"} { return ::$name }
        return $ns\::$name
    }

    # A coroutine-enabled REPL shell for testing
    proc shell {} {
        coroutine ::actor::main ::actor::repl
        vwait forever
    }
    proc repl {} {
        while 1 {
            set cmd [get-command]
            set code [catch { uplevel #0 $cmd } result opts]
            if {$code == 1} {
                puts [dict get $opts -errorinfo]
            } elseif {[string length $result]} {
                puts $result
            }
        }
    }

    proc get-command {} {
        set cmd [prompt %]
        while {![info complete $cmd]} {
            append cmd \n [prompt >]
        }
        return $cmd
    }

    proc prompt p {
        puts -nonewline "$p "
        flush stdout
        fileevent stdin readable [lambda return {
            $return [gets stdin]
        } [info coroutine]]
        yield
    }
    proc lambda {params body args} {
        list ::apply [list $params $body] {*}$args
    }
}

if {$argv0 eq [info script]} {
    actor shell
}

$ tclsh actor.tcl
% actor create adder
::adder
% adder method add {a b} { expr {$a + $b} }
add
% adder add 2 3
5
% actor create summer
::summer
% summer method sum args {
>   set sum 0
>   foreach x $args { set sum [adder add $sum $x] }
>   puts "sum = $sum"
> }
sum
% summer sum 1 2 3 4 5
% sum = 15