X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=919ebb1ef16de0976c43b400bafc9684cf48a5f3;hp=270b25f452909e5a000780bd7de5e968d47d63d2;hb=6ddb48051db9d47eaa28f3e7561622b145e3725a;hpb=d3202269c645127c176cad41185fa0f95be34d89 diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm index 270b25f..919ebb1 100644 --- a/8sync/systems/actors.scm +++ b/8sync/systems/actors.scm @@ -48,7 +48,7 @@ actor-id-string mlambda define-mhandler - make-action-dispatch + simple-dispatcher build-actions make-action-dispatch define-simple-actor @@ -126,11 +126,6 @@ (body message-body) (in-reply-to message-in-reply-to) (wants-reply message-wants-reply) - - ;; See XUDD source for these. Not use yet, maybe eventually will be? - ;; XUDD uses them for autoreply. - ;; Requiring mutation on message objects is clearly not great, - ;; but it may be worth it...? Investigate! (replied message-replied set-message-replied!) (deferred-reply message-deferred-reply set-message-deferred-reply!)) @@ -197,7 +192,7 @@ If key not found and DFLT not provided, throw an error." (message (make-message (hive-gen-message-id hive) to-id (actor-id from-actor) action (kwarg-list-to-alist message-body-args)))) - (8sync-nowait (hive-process-message hive message)))) + (8sync (hive-process-message hive message)))) (define (send-message-wait from-actor to-id action . message-body-args) "Send a message from an actor to another, but wait until we get a response" @@ -224,7 +219,7 @@ If key not found and DFLT not provided, throw an error." (actor-id from-actor) '*reply* (kwarg-list-to-alist message-body-args) #:in-reply-to (message-id original-message)))) - (8sync-nowait (hive-process-message hive new-message)))) + (8sync (hive-process-message hive new-message)))) (define (reply-message-wait from-actor original-message . message-body-args) @@ -323,7 +318,7 @@ If key not found and DFLT not provided, throw an error." body body* ...)) (define-syntax mlambda - (syntax-rules () + (lambda (x) "A lambda for building message handlers. Use it like: @@ -334,13 +329,19 @@ Which is like doing manually: (lambda (actor message) (let ((foo (message-ref message foo))) ...))" - ((_ (actor message message-arg ...) - body body* ...) - (lambda (actor message) - (with-message-args (message message-arg ...) body body* ...))))) + (syntax-case x () + ((_ (actor message message-arg ...) + docstring + body ...) + (string? (syntax->datum #'docstring)) + #'(lambda (actor message) + docstring + (with-message-args (message message-arg ...) body ...))) + ((_ (actor message message-arg ...) + body body* ...) + #'(lambda (actor message) + (with-message-args (message message-arg ...) body body* ...)))))) -;; @@: Sadly, docstrings won't work with this... -;; I think we need to bust out syntax-case to make that happen... (define-syntax-rule (define-mhandler (name actor message message-arg ...) body ...) (define name @@ -352,6 +353,8 @@ Which is like doing manually: (let* ((action (message-action message)) (method (assoc-ref action-map action))) (if (not method) + ;; @@: There's every possibility this should be handled in + ;; hive-process-message instead. (throw 'action-not-found "No appropriate action handler found for actor" #:action action @@ -369,6 +372,15 @@ Which is like doing manually: ((_ (action-name handler)) (cons (quote action-name) handler)))) +(define-syntax-rule (build-actions action-item ...) + "Build a mapping of actions. Same syntax as make-action-dispatch +but this doesn't build the dispatcher for you (you probably want to +pass it to simple-dispatcher). + +The advantage here is that since this simply builds an alist, you can +compose it with other action maps." + (list (%expand-action-item action-item) ...)) + (define-syntax make-action-dispatch (syntax-rules () "Expand a list of action names and actions into an alist @@ -390,8 +402,7 @@ more compact following syntax: ((party actor message) (display \"Life of the party!\")))" ((make-action-dispatch action-item ...) - (simple-dispatcher - (list (%expand-action-item action-item) ...))))) + (simple-dispatcher (build-actions action-item ...))))) (define-syntax-rule (define-simple-actor class actions ...) (define-class class () @@ -497,7 +508,7 @@ more compact following syntax: (actor-id hive) '*error* new-message-body #:in-reply-to (message-id original-message)))) - (8sync-nowait (hive-process-message hive new-message)))) + (8sync (hive-process-message hive new-message)))) (define-method (hive-process-message (hive ) message) "Handle one message, or forward it via an ambassador" @@ -522,13 +533,24 @@ more compact following syntax: (define (call-catching-coroutine thunk) (define (call-catching-errors) - (with-throw-handler - #t thunk - (lambda (key . args) - (if (message-needs-reply message) - ;; If the message is waiting on a reply, let them know - ;; something went wrong. - (hive-reply-with-error hive message key args))))) + ;; TODO: maybe parameterize (or attach to hive) and use + ;; maybe-catch-all from agenda.scm + ;; @@: Why not just use with-throw-handler and let the catch + ;; happen at the agenda? That's what we used to do, but + ;; it ended up with a SIGABRT. See: + ;; http://lists.gnu.org/archive/html/bug-guile/2016-05/msg00003.html + (catch #t + thunk + ;; In the actor model, we don't totally crash on errors. + (lambda _ #f) + ;; If an error happens, we raise it + (lambda (key . args) + (if (message-needs-reply message) + ;; If the message is waiting on a reply, let them know + ;; something went wrong. + (hive-reply-with-error hive message key args)) + ;; print error message + (apply print-error-and-continue key args)))) (call-with-prompt (hive-prompt hive) call-catching-errors (lambda (kont actor message) @@ -615,7 +637,7 @@ more compact following syntax: (process-remote-message)))) (define-method (hive-actor-local? (hive ) address) - (hash-ref (hive-actor-registry hive) address)) + (equal? (hive-id hive) (address-hive-id address))) (define-method (hive-register-actor! (hive ) (actor )) (hash-set! (hive-actor-registry hive) (actor-id actor) actor)) @@ -657,16 +679,16 @@ that method for documentation." This is the method actors should call directly (unless they want to supply an id-cookie, in which case they should use create-actor*)." - (8sync (%hive-create-actor (actor-hive from-actor) actor-class - init #f))) + (%hive-create-actor (actor-hive from-actor) actor-class + init #f)) (define* (create-actor* from-actor actor-class id-cookie #:rest init) "Create an instance of actor-class. Return the new actor's id. Like create-actor, but permits supplying an id-cookie." - (8sync (%hive-create-actor (actor-hive from-actor) actor-class - init id-cookie))) + (%hive-create-actor (actor-hive from-actor) actor-class + init id-cookie)) (define (self-destruct actor)