X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=9ba3818b6ff1d6f6e34b0ff33ae65ad8f29ca619;hp=8c4258d725267b189d91c86142f7a62f08e6da4f;hb=6a8c2b1b31fcda7c58bc0a09b627916ae3641d6c;hpb=2ed15994721764395f271f8b21e9860752682483

diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index 8c4258d..9ba3818 100644
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -47,8 +47,8 @@
             actor-id-hive
             actor-id-string
 
-            mlambda
-            make-action-dispatch
+            mlambda define-mhandler
+            simple-dispatcher build-actions make-action-dispatch
             define-simple-actor
 
             <hive>
@@ -316,8 +316,14 @@ If key not found and DFLT not provided, throw an error."
 ;;; Actor utilities
 ;;; ===============
 
+
+(define-syntax-rule (with-message-args (message message-arg ...)
+                                       body body* ...)
+  (let ((message-arg (message-ref message (quote message-arg))) ...)
+    body body* ...))
+
 (define-syntax mlambda
-  (syntax-rules ()
+  (lambda (x)
     "A lambda for building message handlers.
 
 Use it like:
@@ -328,17 +334,32 @@ Which is like doing manually:
   (lambda (actor message)
     (let ((foo (message-ref message foo)))
       ...))"
-    ((_ (actor message message-arg ...)
-        body body* ...)
-     (lambda (actor message)
-       (let ((message-arg (message-ref message (quote 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* ...))))))
+
+(define-syntax-rule (define-mhandler (name actor message message-arg ...)
+                      body ...)
+  (define name
+    (mlambda (actor message message-arg ...)
+             body ...)))
 
 (define (simple-dispatcher action-map)
   (lambda (actor message)
     (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
@@ -356,6 +377,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
@@ -377,8 +407,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 (<actor>)
@@ -509,13 +538,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)
@@ -602,7 +642,7 @@ more compact following syntax:
         (process-remote-message))))
 
 (define-method (hive-actor-local? (hive <hive>) address)
-  (hash-ref (hive-actor-registry hive) address))
+  (equal? (hive-id hive) (address-hive-id address)))
 
 (define-method (hive-register-actor! (hive <hive>) (actor <actor>))
   (hash-set! (hive-actor-registry hive) (actor-id actor) actor))