X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=e2fd27eac767c1464d38e0fb31d8cd00659052e1;hp=e5dd053d74056bdfa6b0865d8c2921724049fe6e;hb=de334e45354276124e0c58138f53c7ce1656c101;hpb=413f6d981a7c4e11f2270c7bd52527d3e5a3a2c1

diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index e5dd053..e2fd27e 100644
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -31,7 +31,6 @@
             big-random-number
             big-random-number-string
             simple-message-id-generator
-            require-slot
 
             <actor>
             actor-id
@@ -48,7 +47,8 @@
             actor-id-hive
             actor-id-string
 
-            make-action-dispatch
+            mlambda define-mhandler
+            simple-dispatcher build-actions make-action-dispatch
             define-simple-actor
 
             <hive>
@@ -105,13 +105,6 @@
       (set! counter (1+ counter))
       (string-append prefix (number->string counter)))))
 
-(define (require-slot slot-name)
-  "Generate something for #:init-thunk to complain about unfilled slot"
-  (lambda ()
-    (throw 'required-slot
-           (format #f "Slot ~s not filled" slot-name)
-           slot-name)))
-
 
 
 ;;; Messages
@@ -264,17 +257,14 @@ If key not found and DFLT not provided, throw an error."
 
 (define-class <actor> ()
   ;; An address object
-  (id #:init-thunk (require-slot "id")
-      #:init-keyword #:id
+  (id #:init-keyword #:id
       #:getter actor-id)
   ;; The hive we're connected to.
   ;; We need this to be able to send messages.
-  (hive #:init-thunk (require-slot "hive")
-        #:init-keyword #:hive
+  (hive #:init-keyword #:hive
         #:accessor actor-hive)
   ;; How we receive and process new messages
-  (message-handler #:init-thunk (require-slot "message-handler")
-                   #:allocation #:each-subclass))
+  (message-handler #:allocation #:each-subclass))
 
 (define-method (actor-message-handler (actor <actor>))
   (slot-ref actor 'message-handler))
@@ -326,11 +316,44 @@ 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 ()
+    "A lambda for building message handlers.
+
+Use it like:
+  (mlambda (actor message foo)
+    ...)
+
+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* ...)))))
+
+;; @@: 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
+    (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
@@ -343,11 +366,20 @@ If key not found and DFLT not provided, throw an error."
   (syntax-rules ()
     ((_ ((action-name action-args ...) body ...))
      (cons (quote action-name)
-           (lambda (action-args ...)
+           (mlambda (action-args ...)
              body ...)))
     ((_ (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
@@ -369,8 +401,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>)
@@ -387,8 +418,6 @@ more compact following syntax:
 (define-generic hive-handle-failed-forward)
 
 (define-class <hive> (<actor>)
-  ;; This gets set to itself immediately after being created
-  (hive #:init-value #f)
   (actor-registry #:init-thunk make-hash-table
                   #:getter hive-actor-registry)
   (msg-id-generator #:init-thunk simple-message-id-generator