From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Tue, 3 Jan 2017 01:20:58 +0000 (-0600)
Subject: actors: Implicit from-actor argument <-foo methods, and add rest of <-foo*.
X-Git-Tag: v0.4.0~28
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=dc2155083a90de90e24f5341b837d4d96ce2898c;p=8sync.git

actors: Implicit from-actor argument <-foo methods, and add rest of <-foo*.

* 8sync/actors.scm (<-, <-wait, <-reply, <-reply-wait): from-actor is
now implicitly supplied via %current-actor parameter.
(<-*, <-reply*): New procedures.
(<-wait*, <-reply-wait*): Now pull from-actor from #:actor.

* 8sync/actors.scm:
* 8sync/systems/irc.scm:
* demos/actors/botherbotherbother.scm:
* demos/actors/robotscanner.scm:
* demos/actors/simplest-possible.scm:
* demos/ircbot.scm:
* tests/test-actors.scm: Update all callers of <-foo procedures to drop
from-actor argument.

* doc/8sync-new-manual.org: Update documentation of <-foo procedures to
drop from-actor argument.
---

diff --git a/8sync/actors.scm b/8sync/actors.scm
index 37f321b..6e772c6 100644
--- a/8sync/actors.scm
+++ b/8sync/actors.scm
@@ -71,7 +71,7 @@
 
             message-auto-reply?
 
-            <- <-wait <-wait* <-reply <-reply-wait <-reply-wait*
+            <- <-* <-wait <-wait* <-reply <-reply* <-reply-wait <-reply-wait*
 
             call-with-message msg-receive msg-val
 
@@ -196,51 +196,78 @@
         ;;   confusing.
         (8sync (hive-process-message hive new-message)))))
 
-
-(define (<- from-actor to-id action . message-body-args)
+(define (<- to-id action . message-body-args)
   "Send a message from an actor to another actor"
-  (send-message '() from-actor to-id action
+  (send-message '() (%current-actor) to-id action
                 #f #f message-body-args))
 
-(define (<-wait* send-options from-actor to-id action . message-body-args)
-  "Like <-wait, but allows extra parameters, for example whether to
-#:accept-errors"
-  (apply wait-maybe-handle-errors
-         (send-message send-options from-actor to-id action
-                       #f #t message-body-args)
-         send-options))
+(define (<-* send-options to-id action . message-body-args)
+  "Like <-*, but allows extra parameters via send-options"
+  (define* (really-send #:key (actor (%current-actor))
+                        #:allow-other-keys)
+    (send-message send-options actor to-id action
+                  #f #f message-body-args))
+  (apply really-send send-options))
 
-(define (<-wait from-actor to-id action . message-body-args)
+(define (<-wait to-id action . message-body-args)
   "Send a message from an actor to another, but wait until we get a response"
-  (apply <-wait* '() from-actor to-id action message-body-args))
+  (wait-maybe-handle-errors
+   (send-message '() (%current-actor) to-id action
+                 #f #t message-body-args)))
+
+(define (<-wait* send-options to-id action . message-body-args)
+  "Like <-wait, but allows extra parameters, for example whether to
+#:accept-errors"
+  (define* (really-send #:key (actor (%current-actor))
+                        #:allow-other-keys)
+    (apply wait-maybe-handle-errors
+           (send-message send-options actor to-id action
+                         #f #t message-body-args)
+           send-options))
+  (apply really-send send-options))
 
 ;; TODO: Intelligently ~propagate(ish) errors on -wait functions.
 ;;   We might have `send-message-wait-brazen' to allow callers to
 ;;   not have an exception thrown and instead just have a message with
 ;;   the appropriate '*error* message returned.
 
-(define (<-reply from-actor original-message . message-body-args)
+(define (<-reply original-message . message-body-args)
   "Reply to a message"
-  (send-message '() from-actor (message-from original-message) '*reply*
+  (send-message '() (%current-actor) (message-from original-message) '*reply*
                 original-message #f message-body-args))
 
-(define (<-auto-reply from-actor original-message)
+(define (<-reply* send-options original-message . message-body-args)
+  "Like <-reply, but allows extra parameters via send-options"
+  (define* (really-send #:key (actor (%current-actor))
+                        #:allow-other-keys)
+    (send-message send-options actor
+                  (message-from original-message) '*reply*
+                  original-message #f message-body-args))
+  (apply really-send send-options))
+
+(define (<-auto-reply actor original-message)
   "Auto-reply to a message.  Internal use only!"
-  (send-message '() from-actor (message-from original-message) '*auto-reply*
+  (send-message '() actor (message-from original-message) '*auto-reply*
                 original-message #f '()))
 
-(define (<-reply-wait* send-options from-actor original-message
-                       . message-body-args)
+(define (<-reply-wait original-message . message-body-args)
   "Reply to a messsage, but wait until we get a response"
-  (apply wait-maybe-handle-errors
-         (send-message send-options from-actor
-                       (message-from original-message) '*reply*
-                       original-message #t message-body-args)
-         send-options))
+  (wait-maybe-handle-errors
+   (send-message '() (%current-actor)
+                 (message-from original-message) '*reply*
+                 original-message #t message-body-args)))
 
-(define (<-reply-wait from-actor original-message . message-body-args)
-  "Reply to a messsage, but wait until we get a response"
-  (apply <-reply-wait* '() from-actor original-message message-body-args))
+(define (<-reply-wait* send-options original-message
+                       . message-body-args)
+  "Like <-reply-wait, but allows extra parameters via send-options"
+  (define* (really-send #:key (actor (%current-actor))
+                        #:allow-other-keys)
+    (apply wait-maybe-handle-errors
+           (send-message send-options actor
+                         (message-from original-message) '*reply*
+                         original-message #t message-body-args)
+           send-options))
+  (apply really-send send-options))
 
 (define* (wait-maybe-handle-errors message
                                    #:key accept-errors
@@ -421,7 +448,7 @@ to come after class definition."
     (hash-map->list (lambda (actor-id actor) actor-id)
                     (hive-actor-registry hive)))
   (for-each (lambda (actor-id)
-              (<- hive actor-id '*cleanup*))
+              (<- actor-id '*cleanup*))
             actor-ids))
 
 (define* (make-hive #:key hive-id)
@@ -713,7 +740,7 @@ Like create-actor, but permits supplying an id-cookie."
 Unless #:cleanup is set to #f, this will first have the actor handle
 its '*cleanup* action handler."
   (when cleanup
-    (<-wait actor (actor-id actor) '*cleanup*))
+    (<-wait (actor-id actor) '*cleanup*))
   (hash-remove! (hive-actor-registry (actor-hive actor))
                 (actor-id actor)))
 
@@ -745,7 +772,7 @@ its '*cleanup* action handler."
 
 (define (bootstrap-message hive to-id action . message-body-args)
   (wrap
-   (apply <- hive to-id action message-body-args)))
+   (apply <-* `(#:actor ,hive) to-id action message-body-args)))
 
 
 
diff --git a/8sync/systems/irc.scm b/8sync/systems/irc.scm
index aad138d..40d02eb 100755
--- a/8sync/systems/irc.scm
+++ b/8sync/systems/irc.scm
@@ -189,7 +189,7 @@
      (format socket "JOIN ~a~a" channel irc-eol))
    (irc-bot-channels irc-bot))
 
-  (<- irc-bot (actor-id irc-bot) 'main-loop))
+  (<- (actor-id irc-bot) 'main-loop))
 
 (define (irc-bot-main-loop irc-bot message)
   (define socket (irc-bot-socket irc-bot))
@@ -212,7 +212,7 @@
    ;;  'done)
    ;; Otherwise, let's read till the next line!
    (else
-    (<- irc-bot (actor-id irc-bot) 'main-loop))))
+    (<- (actor-id irc-bot) 'main-loop))))
 
 (define* (irc-bot-send-line-action irc-bot message
                                    channel line #:key emote?)
diff --git a/demos/actors/botherbotherbother.scm b/demos/actors/botherbotherbother.scm
index 4911afa..2e72b2d 100755
--- a/demos/actors/botherbotherbother.scm
+++ b/demos/actors/botherbotherbother.scm
@@ -59,8 +59,7 @@
                (while (not (student-dead actor))
                  (format #t "~a: Bother bother bother!\n"
                          (actor-id-actor actor))
-                 (<- actor target
-                     'be-bothered
+                 (<- target 'be-bothered
                      #:noise "Bother bother bother!\n"))))
 
             (be-lambda-consvardraed
@@ -89,8 +88,7 @@
                 (actor-id actor))
         (hash-for-each
          (lambda (student _)
-           (<- actor student
-               'be-lambda-consvardraed)
+           (<- student 'be-lambda-consvardraed)
            ;; Remove student from bothering list
            (hash-remove! whos-bothering student))
          whos-bothering))
diff --git a/demos/actors/robotscanner.scm b/demos/actors/robotscanner.scm
index f620ba8..d2c919c 100644
--- a/demos/actors/robotscanner.scm
+++ b/demos/actors/robotscanner.scm
@@ -64,15 +64,15 @@
            (define droid (create-actor* actor <droid> "droid"
                                         #:infected infected
                                         #:room room))
-           (<-wait actor droid 'register-with-room))
+           (<-wait droid 'register-with-room))
 
          ;; Link rooms.
          ;; Couldn't this just be folded into the warehouse room init?
          ;; I guess it stress tests more the message sending process
          (when previous-room
-           (<- actor previous-room 'set-next-room
+           (<- previous-room 'set-next-room
                #:id room)
-           (<- actor room 'set-previous-room
+           (<- room 'set-previous-room
                #:id previous-room))
 
          ;; Set up clean droids in the room
@@ -95,7 +95,7 @@
      ;; Add security robot
      (let ((security-robot
             (create-actor actor <security-robot>)))
-       (<- actor security-robot 'begin-mission
+       (<- security-robot 'begin-mission
            #:starting-room first-room
            #:overseer (actor-id actor)))))
 
@@ -128,17 +128,17 @@
     (get-next-room
      (lambda (actor message)
        "Return a reference to the link following this"
-       (<-reply actor message (slot-ref actor 'next-room))))
+       (<-reply message (slot-ref actor 'next-room))))
 
     (get-previous-room
      (lambda (actor message)
        "Return a reference to the link preceding this"
-       (<-reply actor message (slot-ref actor 'previous-room))))
+       (<-reply message (slot-ref actor 'previous-room))))
 
     (list-droids
      (lambda (actor message)
        "Return a list of all the droid ids we know of in this room"
-       (<-reply actor message
+       (<-reply message
                 #:droid-ids (slot-ref actor 'droids))))
 
     (register-droid
@@ -164,8 +164,7 @@
      (lambda (actor message)
        "Register ourselves as being in a room"
        (let ((room-id (slot-ref actor 'room)))
-         (<-wait actor room-id
-                 'register-droid
+         (<-wait room-id 'register-droid
                  #:droid-id (actor-id actor))
          (format #t "Droid ~a registered with room ~a\n"
                  (actor-id-actor actor)
@@ -174,7 +173,7 @@
     (infection-expose
      (lambda (actor message)
        "Leak whether or not we're infected to a security droid"
-       (<-reply actor message (slot-ref actor 'infected))))
+       (<-reply message (slot-ref actor 'infected))))
 
     (get-shot
      (lambda (actor message)
@@ -184,7 +183,7 @@
               (alive (> new-hp 0)))
          ;; Set our health to the new value
          (slot-set! actor 'hp new-hp)
-         (<-reply actor message
+         (<-reply message
                   #:hp-left new-hp
                   #:damage-taken damage
                   #:alive alive)
@@ -219,20 +218,20 @@
   ;; Continue this whil there's still another room to investigate.
   (define response)
   (while room
-    (<- actor overseer 'transmission
+    (<- overseer 'transmission
         #:text (format #f "Entering room ~a..."
                        (address-actor-id room)))
 
     ;; Find all droids in this room and exterminate the infected ones.
     (msg-receive (_ #:key list-droids droid-ids #:allow-other-keys)
-        (<-wait actor room 'list-droids)
+        (<-wait room 'list-droids)
       (for-each
        (lambda (droid-id)
          (cond
           ;; Looks like it's infected
-          ((msg-val (<-wait actor droid-id 'infection-expose))
+          ((msg-val (<-wait droid-id 'infection-expose))
            ;; Inform that it's infected
-           (<- actor overseer 'transmission
+           (<- overseer 'transmission
                #:text (format #f "~a found to be infected... taking out"
                               (address-actor-id droid-id)))
 
@@ -240,24 +239,24 @@
            (let ((still-alive #t))
              (while still-alive
                (msg-receive (response #:key alive #:allow-other-keys)
-                   (<-wait actor droid-id 'get-shot)
-                 (<- actor overseer 'transmission
+                   (<-wait droid-id 'get-shot)
+                 (<- overseer 'transmission
                      #:text (droid-status-format response))
                  (set! still-alive alive)))))
 
           ;; Not infected... inform and go to the next one
           (else
-           (<- actor overseer 'transmission
+           (<- overseer 'transmission
                #:text
                (format #f "~a is clean... moving on."
                        (address-actor-id droid-id))))))
        droid-ids))
 
     ;; Switch to next room, if there is one.
-    (set! room (msg-val (<-wait actor room 'get-next-room))))
+    (set! room (msg-val (<-wait room 'get-next-room))))
 
   ;; Good job everyone!  Shut down the operation.
-  (<- actor overseer 'transmission
+  (<- overseer 'transmission
       #:text "Mission accomplished."))
 
 (define (main . args)
diff --git a/demos/actors/simplest-possible.scm b/demos/actors/simplest-possible.scm
index e9aaac7..4e03782 100644
--- a/demos/actors/simplest-possible.scm
+++ b/demos/actors/simplest-possible.scm
@@ -23,7 +23,7 @@
   (greet-proog
    (lambda (actor message target)
      (display "emo> What's next, Proog?\n")
-     (<- actor target 'greet-emo))))
+     (<- target 'greet-emo))))
 
 (define-simple-actor <proog>
   (greet-emo
diff --git a/demos/ircbot.scm b/demos/ircbot.scm
index b962ad7..1c4ae74 100755
--- a/demos/ircbot.scm
+++ b/demos/ircbot.scm
@@ -41,19 +41,19 @@
      (match action
        ;; The classic botsnack!
        ("botsnack"
-        (<- irc-bot (actor-id irc-bot) 'send-line channel
+        (<- (actor-id irc-bot) 'send-line channel
             "Yippie! *does a dance!*"))
        ;; Return greeting
        ((or "hello" "hello!" "hello." "greetings" "greetings." "greetings!"
             "hei" "hei." "hei!" "hi" "hi!")
-        (<- irc-bot (actor-id irc-bot) 'send-line channel
+        (<- (actor-id irc-bot) 'send-line channel
             (format #f "Oh hi ~a!" speaker)))
 
        ;; --->  Add yours here <---
 
        ;; Default
        (_
-        (<- irc-bot (actor-id irc-bot) 'send-line channel
+        (<- (actor-id irc-bot) 'send-line channel
             "*stupid puppy look*"))))
     ;; Otherwise... just spit the output to current-output-port or whatever
     (_
diff --git a/doc/8sync-new-manual.org b/doc/8sync-new-manual.org
index d0a9967..3e17cbf 100644
--- a/doc/8sync-new-manual.org
+++ b/doc/8sync-new-manual.org
@@ -205,7 +205,7 @@ Change handle-line to this:
 #+BEGIN_SRC scheme
   (define-method (handle-line (irc-bot <my-irc-bot>) speaker channel
                               line emote?)
-    (<- irc-bot (actor-id irc-bot) 'send-line channel
+    (<- (actor-id irc-bot) 'send-line channel
         (format #f "Bawwwwk! ~a says: ~a" speaker line)))
 #+END_SRC
 
@@ -295,7 +295,7 @@ Luckily this is an easy adjustment to make.
       (or (equal? str my-name)
           (equal? str (string-concatenate (list my-name ":")))))
     (when (looks-like-me?)
-      (<- irc-bot (actor-id irc-bot) 'send-line channel
+      (<- (actor-id irc-bot) 'send-line channel
           (format #f "Bawwwwk! ~a says: ~a" speaker line))))
 #+END_SRC
 
@@ -327,22 +327,22 @@ To implement it, we're going to pull out Guile's pattern matcher.
        (match action
          ;; The classic botsnack!
          ("botsnack"
-          (<- irc-bot (actor-id irc-bot) 'send-line channel
+          (<- (actor-id irc-bot) 'send-line channel
               "Yippie! *does a dance!*"))
          ;; Return greeting
          ((or "hello" "hello!" "hello." "greetings" "greetings." "greetings!"
               "hei" "hei." "hei!" "hi" "hi!")
-          (<- irc-bot (actor-id irc-bot) 'send-line channel
+          (<- (actor-id irc-bot) 'send-line channel
               (format #f "Oh hi ~a!" speaker)))
          ("echo"
-          (<- irc-bot (actor-id irc-bot) 'send-line channel
+          (<- (actor-id irc-bot) 'send-line channel
               (string-join action-args " ")))
 
          ;; --->  Add yours here <---
 
          ;; Default
          (_
-          (<- irc-bot (actor-id irc-bot) 'send-line channel
+          (<- (actor-id irc-bot) 'send-line channel
               "*stupid puppy look*"))))))
 #+END_SRC
 
@@ -360,7 +360,7 @@ you're right:
       (or (equal? str my-name)
           (equal? str (string-concatenate (list my-name ":")))))
     (define (respond respond-line)
-      (<- irc-bot (actor-id irc-bot) 'send-line channel
+      (<- (actor-id irc-bot) 'send-line channel
           respond-line))
     (match (string-split line #\space)
       (((? looks-like-me? _) action action-args ...)
@@ -503,7 +503,7 @@ things to:
                               line emote?)
     ;; [... snip ...]
     (define (respond respond-line)
-      (<- irc-bot (actor-id irc-bot) 'send-line (pk 'channel channel)
+      (<- (actor-id irc-bot) 'send-line (pk 'channel channel)
           respond-line))
     ;; [... snip ...]
     )
@@ -533,7 +533,7 @@ to looks like our own username that we respond back to the sender.
                               line emote?)
     ;; [... snip ...]
     (define (respond respond-line)
-      (<- irc-bot (actor-id irc-bot) 'send-line
+      (<- (actor-id irc-bot) 'send-line
           (if (looks-like-me? channel)
               speaker    ; PM session
               channel)   ; normal IRC channel
@@ -615,7 +615,7 @@ Time to get back to work!
   (define (manager-assign-task manager message difficulty)
     "Delegate a task to our direct report"
     (display "manager> Work on this task for me!\n")
-    (<- manager (manager-direct-report manager)
+    (<- (manager-direct-report manager)
         'work-on-this difficulty))
 #+END_SRC
 
@@ -698,7 +698,7 @@ into a micromanager.
   (define (manager-assign-task manager message difficulty)
     "Delegate a task to our direct report"
     (display "manager> Work on this task for me!\n")
-    (<- manager (manager-direct-report manager)
+    (<- (manager-direct-report manager)
         'work-on-this difficulty)
 
     ;; call the micromanagement loop
@@ -710,7 +710,7 @@ into a micromanager.
     "Pester direct report until they're done with their task."
     (display "manager> Are you done yet???\n")
     (let ((still-working
-           (msg-val (<-wait manager (manager-direct-report manager)
+           (msg-val (<-wait (manager-direct-report manager)
                             'done-yet?))))
       (if still-working
           (begin (display "manager> Harumph!\n")
@@ -718,7 +718,7 @@ into a micromanager.
                  (when (actor-alive? manager)
                    (manager-micromanage-loop manager)))
           (begin (display "manager> Oh!  I guess you can go home then.\n")
-                 (<- manager (manager-direct-report manager) 'go-home)))))
+                 (<- (manager-direct-report manager) 'go-home)))))
 #+END_SRC
 
 We've appended a micromanagement loop here... but what's going on?
@@ -746,7 +746,7 @@ Of course, we need to update our worker accordingly as well.
   ;;; New procedures:
   (define (worker-done-yet? worker message)
     "Reply with whether or not we're done yet."
-    (<-reply worker message
+    (<-reply message
              (= (worker-task-left worker) 0)))
 
   (define (worker-go-home worker message)
diff --git a/tests/test-actors.scm b/tests/test-actors.scm
index ea0324c..54d8dbb 100644
--- a/tests/test-actors.scm
+++ b/tests/test-actors.scm
@@ -80,13 +80,13 @@
 (define* (antsy-caller-pester-rep actor message #:key who-to-call)
   (~display "customer> I'm calling customer service about this!\n")
   (msg-receive (first-reply #:key msg)
-      (<-wait actor who-to-call 'field-call)
+      (<-wait who-to-call 'field-call)
     (if (message-auto-reply? first-reply)
         (~display "customer> Whaaaaat?  I can't believe I got voice mail!\n")
         (begin
           (~format "*customer hears*: ~a\n" msg)
           (msg-receive (second-reply #:key *auto-reply*)
-              (<-reply-wait actor first-reply
+              (<-reply-wait first-reply
                             #:msg "Yes, it didn't work, I'm VERY ANGRY!")
             (if (message-auto-reply? second-reply)
                 (~display "customer> Well then!  Harumph.\n")
@@ -98,9 +98,7 @@
 (define (rep-field-call actor message)
   (~display "good-rep> Hm, another call from a customer...\n")
   (msg-receive (reply #:key msg)
-      (<-reply-wait
-       actor message
-       #:msg "Have you tried turning it off and on?")
+      (<-reply-wait message #:msg "Have you tried turning it off and on?")
     (~format "*rep hears*: ~a\n" msg)
     (~display "good-rep> I'm sorry, that's all I can do for you.\n")))