From 40c22324febda345a3a8b50fe9293b2f29ee43d4 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Fri, 11 Dec 2015 18:41:15 -0600 Subject: [PATCH] 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 --- 8sync/agenda.scm | 180 ++++++++++++++++++++---------------------- 8sync/systems/irc.scm | 8 +- tests/test-agenda.scm | 56 ++++++++----- 3 files changed, 127 insertions(+), 117 deletions(-) diff --git a/8sync/agenda.scm b/8sync/agenda.scm index 74f3b19..3bd5787 100644 --- a/8sync/agenda.scm +++ b/8sync/agenda.scm @@ -53,8 +53,6 @@ schedule-segments-split schedule-extract-until! add-segments-contents-to-queue! - %8sync - 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 %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 @@ -473,13 +471,9 @@ Will produce (0 . 0) instead of a negative number, if needed." ;;; 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) @@ -516,95 +510,91 @@ return the wrong thing via (%8sync) and trip themselves up." (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 -(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 diff --git a/8sync/systems/irc.scm b/8sync/systems/irc.scm index 80d4ce1..f8e01b4 100755 --- a/8sync/systems/irc.scm +++ b/8sync/systems/irc.scm @@ -241,10 +241,10 @@ ;; 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 diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm index d62e01c..12826c2 100644 --- 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) + #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (8sync agenda) #:use-module (tests utils)) @@ -260,26 +261,45 @@ ;;; %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) -(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)) -(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)) @@ -336,7 +356,7 @@ (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)) @@ -359,7 +379,7 @@ (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) -- 2.31.1