X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=eed3930679566bf0531ddbbd353869f132248f27;hp=debb606eb09fe743d7454a96b6abf7d1a7a531e2;hb=e767393260e8fd96d8abd71042b6b051b95e5b13;hpb=22d2cc32b43143a32a2989fdc1917e4b5dc7ee96

diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index debb606..eed3930 100644
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -50,7 +50,8 @@
             actor-id-hive
             actor-id-string
 
-            simple-dispatcher build-actions make-action-dispatch
+            build-actions
+
             define-simple-actor
 
             <hive>
@@ -228,25 +229,6 @@
 ;;; Main actor implementation
 ;;; =========================
 
-(define-class <actor> ()
-  ;; An address object
-  (id #:init-keyword #:id
-      #:getter actor-id)
-  ;; The hive we're connected to.
-  ;; We need this to be able to send messages.
-  (hive #:init-keyword #:hive
-        #:accessor actor-hive)
-  ;; How we receive and process new messages
-  (message-handler #:init-value (wrap-apply actor-inheritable-message-handler)
-                   ;; @@: There's no reason not to use #:class instead of
-                   ;;   #:each-subclass anywhere in this file, except for
-                   ;;   Guile bug #25211 (#:class is broken in Guile 2.2)
-                   #:allocation #:each-subclass)
-
-  ;; This is the default, "simple" way to inherit and process messages.
-  (actions #:init-value '()
-           #:allocation #:each-subclass))
-
 (define (actor-inheritable-message-handler actor message)
   (define action (message-action message))
   (define (find-message-handler return)
@@ -270,6 +252,25 @@
     (call/ec find-message-handler))
   (apply method actor message (message-body message)))
 
+(define-class <actor> ()
+  ;; An address object
+  (id #:init-keyword #:id
+      #:getter actor-id)
+  ;; The hive we're connected to.
+  ;; We need this to be able to send messages.
+  (hive #:init-keyword #:hive
+        #:accessor actor-hive)
+  ;; How we receive and process new messages
+  (message-handler #:init-value actor-inheritable-message-handler
+                   ;; @@: There's no reason not to use #:class instead of
+                   ;;   #:each-subclass anywhere in this file, except for
+                   ;;   Guile bug #25211 (#:class is broken in Guile 2.2)
+                   #:allocation #:each-subclass)
+
+  ;; This is the default, "simple" way to inherit and process messages.
+  (actions #:init-value '()
+           #:allocation #:each-subclass))
+
 (define-method (actor-message-handler (actor <actor>))
   (slot-ref actor 'message-handler))
 
@@ -323,63 +324,18 @@
 ;;; Actor utilities
 ;;; ===============
 
-(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
-                 #:actor actor
-                 #:message message
-                 #:available-actions (map car action-map)))
-      (apply method actor message (message-body message)))))
-
-(define-syntax %expand-action-item
-  (syntax-rules ()
-    ((_ (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
-
-You can use this like the following:
-  (make-action-dispatch
-   (cookies
-    (lambda (actor message)
-      (display \"I love cookies!\n\")))
-   (party
-    (lambda (actor message)
-      (display \"Life of the party!\"))))
-
-Alternately, if you'd like to skip the lambda, you could use the slightly
-more compact following syntax:
-  (make-action-dispatch
-   ((cookies actor message)
-     (display \"I love cookies!\n\"))
-   ((party actor message)
-     (display \"Life of the party!\")))"
-    ((make-action-dispatch action-item ...)
-     (simple-dispatcher (build-actions action-item ...)))))
-
-(define-syntax-rule (define-simple-actor class actions ...)
+(define-syntax-rule (build-actions (symbol method) ...)
+  "Construct an alist of (symbol . method), where the method is wrapped
+with wrap-apply to facilitate live hacking and allow the method definition
+to come after class definition."
+  (list
+   (cons (quote symbol)
+         (wrap-apply method)) ...))
+
+(define-syntax-rule (define-simple-actor class action ...)
   (define-class class (<actor>)
-    (message-handler
-     #:init-value (make-action-dispatch actions ...)
-     #:allocation #:each-subclass)))
+    (actions #:init-value (build-actions action ...)
+             #:allocation #:each-subclass)))
 
 
 ;;; The Hive
@@ -410,12 +366,12 @@ more compact following syntax:
   ;; to send the message, then carry on their way
   (prompt #:init-thunk make-prompt-tag
           #:getter hive-prompt)
-  (message-handler
-   #:init-value
-   (make-action-dispatch
-    ;; This is in the case of an ambassador failing to forward a message...
-    ;; it reports it back to the hive
-    (*failed-forward* hive-handle-failed-forward))))
+  (actions #:allocation #:each-subclass
+           #:init-value
+           (build-actions
+            ;; This is in the case of an ambassador failing to forward a
+            ;; message... it reports it back to the hive
+            (*failed-forward* hive-handle-failed-forward))))
 
 (define-method (hive-handle-failed-forward (hive <hive>) message)
   "Handle an ambassador failing to forward a message"