Switch from (%8sync (%run)) to just (%8sync) or (%8sync-run)

This is a major overhaul inspired by the fact that (%8sync-port) never
worked (or at least not since error propagation), because the error
resolution code in (%8sync) was specific to (%run).

* 8sync/agenda.scm (%run, %run-at, %run-delay, %port-request)
  (%port-remove-request): Removed variables.
  (%8sync, %8sync-run, %8sync-run-at, %8sync-run-delay)
  (%8sync-port, %8sync-port-remove): Updated to new pattern.
  (%run-with-return, %8sync-immediate): Rename.
* 8sync/systems/irc.scm (make-basic-irc-handler):
  Update from %8sync-run to %8sync
* tests/test-agenda.scm (run-in-fake-agenda): new helper macro
  (test-%run-and-friends): Updated to work with run-in-fake-agenda,
    and upated several calls
  (talk-about-the-zoo, indirection-remote-func-breaks): Updated

diff --git a/8sync/agenda.scm b/8sync/agenda.scm
index 74f3b192edb7076c0c421a33871ff4e615ca2003..3bd5787962ff4f25b3c62c9421b4bdcf55331e92 100644 (file)
--- a/8sync/agenda.scm
+++ b/8sync/agenda.scm
@@ -53,8 +53,6 @@
             schedule-segments-split schedule-extract-until!
             add-segments-contents-to-queue!
 
             schedule-segments-split schedule-extract-until!
             add-segments-contents-to-queue!
 

-            %8sync
-

             <run-request>
             make-run-request run-request?
             run-request-proc run-request-when
             <run-request>
             make-run-request run-request?
             run-request-proc run-request-when


@@ -70,7 +68,7 @@
 
             run-it wrap wrap-apply run run-at run-delay
 
 
             run-it wrap wrap-apply run run-at run-delay
 

-            %run %run-at %run-delay %port-request %port-remove-request
+            %8sync %8sync-delay

             %8sync-run %8sync-run-at %8sync-run-delay
             %8sync-port %8sync-port-remove
             
             %8sync-run %8sync-run-at %8sync-run-delay
             %8sync-port %8sync-port-remove
             


@@ -473,13 +471,9 @@ Will produce (0 . 0) instead of a negative number, if needed."
 ;;; Asynchronous escape to run things
 ;;; =================================
 
 ;;; Asynchronous escape to run things
 ;;; =================================
 

-(define-syntax-rule (%8sync async-request)
-  "Run BODY asynchronously at a prompt, passing args to make-future.
-
-Runs things asynchronously (8synchronously?)"
-  (propagate-%async-exceptions
-   (abort-to-prompt (current-agenda-prompt)
-                    async-request)))
+(define-syntax-rule (%8sync-abort-to-prompt async-request)
+  (abort-to-prompt (current-agenda-prompt)
+                   async-request))

 
 ;; Async port request and run-request meta-requests
 (define (make-async-request proc)
 
 ;; Async port request and run-request meta-requests
 (define (make-async-request proc)


@@ -516,95 +510,91 @@ return the wrong thing via (%8sync) and trip themselves up."
                (wrapped-exception-stacks body-result))
         body-result)))
 
                (wrapped-exception-stacks body-result))
         body-result)))
 

-(define-syntax-rule (%run body ...)
-  (%run-at body ... #f))
-
-(define-syntax-rule (%run-at body ... when)
-  ;; Send an asynchronous request to apply a continuation to the
-  ;; following function, then handle that as a request to the agenda
-  (make-async-request
-   (lambda (kont)
-     ;; We're making a run request
-     (make-run-request
-      ;; Wrapping the following execution to run...
-      (wrap
-       ;; Once we get the result from the inner part, we'll resume
-       ;; this continuation, but first
-       ;; @@: Is this running immediately, or queueing the result
-       ;;   after evaluation for the next agenda tick?  It looks
-       ;;   like evaluating immediately.  Is that what we want?
-       (kont
-        ;; Any unhandled errors are caught
-        (let ((exception-stack #f))
-          (catch #t
-            ;; Run the actual code the user requested
-            (lambda ()
-              body ...)
-            ;; If something bad happened and we didn't catch it,
-            ;; we'll wrap it up in such a way that the continuation
-            ;; can address it
-            (lambda (key . args)
-              (cond
-               ((eq? key '8sync-caught-error)
-                (match args
-                  ((orig-key orig-args orig-stacks)
-                   (make-wrapped-exception
-                    orig-key orig-args
-                    (cons exception-stack orig-stacks)))))
-               (else
-                (make-wrapped-exception key args
-                                        (list exception-stack)))))
-            (lambda _
-              (set! exception-stack (make-stack #t 1 0)))))))
-      when))))
-
-(define-syntax-rule (%run-delay body ... delay-time)
-  (%run-at body ... (tdelta delay-time)))
-
-(define-syntax-rule (%port-request port port-request-args ...)
-  (make-async-request
-   (lambda (kont)
-     (list (make-port-request port port-request-args ...)
-           (make-run-request (wrap kont) #f)))))
-
-(define-syntax-rule (%port-remove-request port)
-  (make-async-request
-   (lambda (kont)
-     (list (make-port-remove-request port)
-           (make-run-request (wrap kont) #f)))))
-
-
-;; Sugar
-(define-syntax-rule (%8sync-run rest ...)
-  "Sugar for (%8sync (%run ...))"
-  (%8sync (%run rest ...)))
-
-(define-syntax-rule (%8sync-run-at rest ...)
-  "Sugar for (%8sync (%run-at ...))"
-  (%8sync (%run-at rest ...)))
-
-(define-syntax-rule (%8sync-run-delay rest ...)
-  "Sugar for (%8sync (%run-delay ...))"
-  (%8sync (%run-delay rest ...)))
-
-(define-syntax-rule (%8sync-port rest ...)
-  "Sugar for (%8sync (%port-request ...))"
-  (%8sync (%port-request rest ...)))
-
-(define-syntax-rule (%8sync-port-remove rest ...)
-  "Sugar for (%8sync (%port-remove-request ...))"
-  (%8sync (%port-remove-request rest ...)))
+(define-syntax %8sync
+  (syntax-rules ()
+    "Run BODY asynchronously (8synchronously?) at a prompt, then return.
+
+Possibly specify WHEN as the second argument."
+    ((%8sync body)
+     (%8sync-run body))
+    ((%8sync body when)
+     (%8sync-run-at body when))))
+
+(define-syntax-rule (%8sync-run body ...)
+  (%8sync-run-at body ... #f))
+
+(define-syntax-rule (%8sync-run-at body ... when)
+  (propagate-%async-exceptions
+   (%8sync-abort-to-prompt
+    ;; Send an asynchronous request to apply a continuation to the
+    ;; following function, then handle that as a request to the agenda
+    (make-async-request
+     (lambda (kont)
+       ;; We're making a run request
+       (make-run-request
+        ;; Wrapping the following execution to run...
+        (wrap
+         ;; Once we get the result from the inner part, we'll resume
+         ;; this continuation, but first
+         ;; @@: Is this running immediately, or queueing the result
+         ;;   after evaluation for the next agenda tick?  It looks
+         ;;   like evaluating immediately.  Is that what we want?
+         (kont
+          ;; Any unhandled errors are caught
+          (let ((exception-stack #f))
+            (catch #t
+              ;; Run the actual code the user requested
+              (lambda ()
+                body ...)
+              ;; If something bad happened and we didn't catch it,
+              ;; we'll wrap it up in such a way that the continuation
+              ;; can address it
+              (lambda (key . args)
+                (cond
+                 ((eq? key '8sync-caught-error)
+                  (match args
+                    ((orig-key orig-args orig-stacks)
+                     (make-wrapped-exception
+                      orig-key orig-args
+                      (cons exception-stack orig-stacks)))))
+                 (else
+                  (make-wrapped-exception key args
+                                          (list exception-stack)))))
+              (lambda _
+                (set! exception-stack (make-stack #t 1 0)))))))
+        when))))))
+
+(define-syntax-rule (%8sync-run-delay body ... delay-time)
+  (%8sync-run-at body ... (tdelta delay-time)))
+
+(define-syntax-rule (%8sync-delay args ...)
+  (%8sync-run-delay args ...))
+
+(define-syntax-rule (%8sync-port port port-request-args ...)
+  (%8sync-abort-to-prompt
+   (make-async-request
+    (lambda (kont)
+      (list (make-port-request port port-request-args ...)
+            (make-run-request kont #f))))))
+
+(define-syntax-rule (%8sync-port-remove port)
+  (%8sync-abort-to-prompt
+   (make-async-request
+    (lambda (kont)
+      (list (make-port-remove-request port)
+            (make-run-request kont #f))))))

 
 
 ;; TODO: Write (%run-immediately)
 
 
 
 ;; TODO: Write (%run-immediately)
 

-;; TODO
-(define-syntax-rule (%run-with-return return body ...)
-  (make-async-request
-   (lambda (kont)
-     (let ((return kont))
-       (lambda ()
-         body ...)))))
+(define-syntax-rule (%8sync-immediate body)
+  "Run body asynchronously but ignore its result...
+forge ahead in our current function!"
+  (%8sync-abort-to-prompt
+   (make-async-request
+    (lambda (kont)
+      (list (make-run-request kont #f)
+            (make-run-request body #f))))))

 
 (define-syntax-rule (catch-8sync exp (handler-key handler) ...)
   (catch '8sync-caught-error
 
 (define-syntax-rule (catch-8sync exp (handler-key handler) ...)
   (catch '8sync-caught-error

diff --git a/8sync/systems/irc.scm b/8sync/systems/irc.scm
index 80d4ce182f4fe2a7ba65aa729f56c63f0de3252c..f8e01b43c02a0f94309538a368be54cb6b966a8f 100755 (executable)
--- a/8sync/systems/irc.scm
+++ b/8sync/systems/irc.scm
@@ -241,10 +241,10 @@
              ;; reset buffer
              (set! buffer '())
              ;; run it
              ;; reset buffer
              (set! buffer '())
              ;; run it

-             (%8sync-run (handle-line
-                          socket
-                          ready-line
-                          username))))
+             (%8sync (handle-line
+                      socket
+                      ready-line
+                      username))))

           (_ #f)))
       ;; I need to shut things down on EOF object
       (cond
           (_ #f)))
       ;; I need to shut things down on EOF object
       (cond

diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm
index d62e01ce284f777e831884cf9e9a0610413886f5..12826c29b02efad4b40a4a891ec874ba71f4c8e8 100644 (file)
--- a/tests/test-agenda.scm
+++ b/tests/test-agenda.scm
@@ -23,6 +23,7 @@
 (define-module (tests test-agenda)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 q)
 (define-module (tests test-agenda)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 q)

+  #:use-module (ice-9 match)

   #:use-module (ice-9 receive)
   #:use-module (8sync agenda)
   #:use-module (tests utils))
   #:use-module (ice-9 receive)
   #:use-module (8sync agenda)
   #:use-module (tests utils))


@@ -260,26 +261,45 @@
 ;;; %run, %8sync and friends tests
 ;;; ==============================
 
 ;;; %run, %8sync and friends tests
 ;;; ==============================
 

-(define (test-%run-and-friends async-request expected-when)
-  (let* ((fake-kont (speak-it))
-         (run-request ((@@ (8sync agenda) setup-async-request)
-                       fake-kont async-request)))
-    (test-equal (car async-request) '*async-request*)
-    (test-equal (run-request-when run-request) expected-when)
-    ;; we're using speaker as a fake continuation ;p
-    ((run-request-proc run-request))
-    (test-equal (fake-kont)
-                '("applesauce"))))
-
-(test-%run-and-friends (%run (string-concatenate '("apple" "sauce")))
+(define-syntax-rule (run-in-fake-agenda
+                     code-to-run)
+  (let ((agenda (make-agenda)))
+    (parameterize ((%current-agenda agenda))
+      (call-with-prompt
+       (agenda-prompt-tag agenda)
+       (lambda ()
+         (list '*normal-result* code-to-run))
+       (lambda (kont async-request)
+         (list '*caught-kont*
+               kont async-request
+               ((@@ (8sync agenda) setup-async-request)
+                kont async-request)))))))
+
+(define (test-%run-and-friends run-result expected-when)
+  (match run-result
+    (('*caught-kont* kont async-request setup-request)
+     (let* ((fake-kont (speak-it))
+            (run-request ((@@ (8sync agenda) setup-async-request)
+                          fake-kont async-request)))
+       (test-equal (car async-request) '*async-request*)
+       (test-equal (run-request-when run-request) expected-when)
+       ;; we're using speaker as a fake continuation ;p
+       ((run-request-proc run-request))
+       (test-equal (fake-kont)
+                   '("applesauce"))))))
+
+(test-%run-and-friends (run-in-fake-agenda
+                        (%8sync (string-concatenate '("apple" "sauce"))))

                        #f)
 
                        #f)
 

-(test-%run-and-friends (%run-at (string-concatenate '("apple" "sauce"))
-                                '(8 . 0))
+(test-%run-and-friends (run-in-fake-agenda
+                        (%8sync (string-concatenate '("apple" "sauce"))
+                                '(8 . 0)))

                        '(8 . 0))
 
                        '(8 . 0))
 

-(test-%run-and-friends (%run-delay (string-concatenate '("apple" "sauce"))
-                                   8)
+(test-%run-and-friends (run-in-fake-agenda
+                        (%8sync-delay (string-concatenate '("apple" "sauce"))
+                                      8))

                        ;; whoa, I'm surprised equal? can
                        ;; compare records like this
                        (tdelta 8))
                        ;; whoa, I'm surprised equal? can
                        ;; compare records like this
                        (tdelta 8))


@@ -336,7 +356,7 @@
   (speaker "Today I went to the zoo and I saw...\n")
   (speaker
    (string-concatenate
   (speaker "Today I went to the zoo and I saw...\n")
   (speaker
    (string-concatenate

-    `("A " ,(symbol->string (%8sync (%run (return-monkey)))) "!\n"))))
+    `("A " ,(symbol->string (%8sync (return-monkey))) "!\n"))))

 
 (begin
   (set! speaker (speak-it))
 
 (begin
   (set! speaker (speak-it))


@@ -359,7 +379,7 @@
 
 (define (indirection-remote-func-breaks)
   (speaker "bebop\n")
 
 (define (indirection-remote-func-breaks)
   (speaker "bebop\n")

-  (%8sync (%run (remote-func-breaks)))
+  (%8sync (remote-func-breaks))

   (speaker "bidop\n"))
 
 (define* (local-func-gets-break #:key with-indirection)
   (speaker "bidop\n"))
 
 (define* (local-func-gets-break #:key with-indirection)