X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=tests%2Ftest-actors.scm;h=873085eb7aca925014d38be2df3c9f09f4e4c28d;hb=38afa0b278e17953b64764d800beaaa6368f70be;hp=7504e13ecabea364e7f5b2dfaea4120dfeef1c05;hpb=efcf5c743041f076344e966526b3175aa83d529f;p=8sync.git

diff --git a/tests/test-actors.scm b/tests/test-actors.scm
index 7504e13..873085e 100644
--- a/tests/test-actors.scm
+++ b/tests/test-actors.scm
@@ -18,70 +18,80 @@
 
 (define-module (tests test-actors)
   #:use-module (srfi srfi-64)
-  #:use-module (8sync systems actors)
+  #:use-module (8sync actors)
+  #:use-module (fibers)
+  #:use-module (fibers conditions)
+  #:use-module (fibers operations)
+  #:use-module (fibers timers)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 receive)
+  #:use-module (oop goops)
   #:use-module (tests utils))
 
 (test-begin "test-actors")
 
+
+;;; Test waiting on a response
 
-;;; Some test dummy values
-;;; ======================
+(define-actor <Responder> (<actor>)
+  ((ping-pong
+    (lambda (actor message ping-val)
+      ;; Returns two values to its continuation: its ping-val, and the
+      ;; value of its own response-val slot.
+      (values (.response-val actor) ping-val))))
+  (response-val #:init-keyword #:response-val
+                #:accessor .response-val))
 
-(define %fake-hive-id "the-main-hive")
-;; Some fake ids for actors
-(define %fake-emo-id (make-address "emo" %fake-hive-id))
-(define %fake-proog-id (make-address "proog" %fake-hive-id))
-(define %fake-hive-actor-id (make-address "hive" %fake-hive-id))
+(define-actor <Requester> (<actor>)
+  ((run requester-run))
+  (done #:init-keyword #:done
+        #:accessor .done)
+  (test-box #:init-keyword #:test-box
+            #:accessor .test-box))
 
-(define test-message
-  (make-message ((simple-message-id-generator))
-                %fake-emo-id
-                %fake-hive-actor-id ; Bootstrap messages come from the hive
-                'greet-proog `((target . ,%fake-proog-id))))
+(define (requester-run requester m)
+  (define beeper
+    (create-actor <Responder> #:response-val 'beep))
+  (define booper
+    (create-actor <Responder> #:response-val 'boop))
+  (define bopper
+    (create-actor <Responder> #:response-val 'bop))
+  (define borker
+    (create-actor <Responder> #:response-val 'bork))
+  (receive (v1 v2)
+      (<-wait beeper 'ping-pong 1)
+    (test-equal v1 'beep)
+    (test-equal v2 1))
+  (receive (v1 v2)
+      (<-wait booper 'ping-pong 2)
+    (test-equal v1 'boop)
+    (test-equal v2 2))
+  (receive (v1 v2)
+      (<-wait bopper 'ping-pong 3)
+    (test-equal v1 'bop)
+    (test-equal v2 3))
+  (receive (v1 v2)
+      (<-wait borker 'ping-pong 4)
+    (test-equal v1 'bork)
+    (test-equal v2 4))
+  (atomic-box-set! (.test-box requester) 'we-did-it)
+  (signal-condition! (.done requester)))
 
-;;; Actor utilities
-;;; ===============
-
-;;; Message tests
-;;; =============
-
-(let ((monkey-message
-       (make-message 'id 'to 'from 'action
-                     '((monkey . banana)))))
-  ;; A key we have
-  (test-equal (message-ref monkey-message 'monkey)
-    'banana)
-
-  ;; A key we don't have
-  (let ((caught-error #f))
-    (catch 'message-missing-key
-      (lambda ()
-        (message-ref monkey-message 'coo-coo))
-      (lambda (. args)
-        (set! caught-error #t)))
-    (test-assert caught-error))
-
-  ;; A key we don't have, with a default set
-  (test-equal (message-ref monkey-message 'coo-coo 'danger-danger)
-    'danger-danger))
-
-
-;; Make sure our test message serializes and deserializes okay
-
-(let ((reread-message
-       (read-message-from-string
-        (with-output-to-string
-          (lambda () (write-message test-message))))))
-  (test-assert (message? reread-message))
-  ;; Make sure that all the properties are the same from
-  ;; the original message to the re-read message
-  (for-each
-   (lambda (getter)
-     (test-equal (getter test-message) (getter reread-message)))
-   (list message-id message-to message-from message-action message-body
-         message-in-reply-to message-wants-reply
-         (@@ (8sync systems actors) message-replied)
-         (@@ (8sync systems actors) message-deferred-reply))))
+(let ((test-box (make-atomic-box 'not-yet))
+      (done (make-condition)))
+  (run-hive
+   (lambda (hive)
+     (define requester (create-actor <Requester>
+                                     #:done done
+                                     #:test-box test-box))
+     (<- requester 'run)
+     (perform-operation
+      (choice-operation (wait-operation done)
+                        ;; if somehow this times out after 5 seconds,
+                        ;; something is deeply wrong
+                        (sleep-operation 5)))
+     (test-equal (atomic-box-ref test-box)
+       'we-did-it))))
 
 (test-end "test-actors")
 (test-exit)