X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=eightsync%2Fagenda.scm;h=ede753fee409eb4a3f88b6728876fc77b079e74d;hp=2d5bc8d19679286669305a43caa43b2b587cfa83;hb=2cf0efca6f8abb4938cec1cc4d00bb96dcc4de87;hpb=bb0d4fc5de7ca8282542d8ec5b3b4ce6389b7cce diff --git a/eightsync/agenda.scm b/eightsync/agenda.scm index 2d5bc8d..ede753f 100644 --- a/eightsync/agenda.scm +++ b/eightsync/agenda.scm @@ -30,6 +30,8 @@ make-async-prompt-tag + list->q make-q* + make-time-segment time-segment? time-segment-time time-segment-queue @@ -64,8 +66,15 @@ run-it wrap wrap-apply run run-at run-delay %port-request %run %run-at %run-delay - 8port-request 8run 8run-at 8run-delay + catch-8sync catch-%8sync + + ;; used for introspecting the error, but a method for making + ;; is not exposed + wrapped-exception? + wrapped-exception-key wrapped-exception-args + wrapped-exception-stacks + print-error-and-continue %current-agenda @@ -139,6 +148,19 @@ Generally done automatically for the user through (make-agenda)." "Can't get current agenda prompt if there's no current agenda!") (agenda-prompt-tag current-agenda)))) +;; helper for making queues for an agenda +(define (list->q lst) + "Makes a queue composed of LST items" + (let ((q (make-q))) + (for-each + (lambda (x) + (enq! q x)) + lst) + q)) + +(define (make-q* . args) + "Makes a queue and populates it with this invocation's ARGS" + (list->q args)) ;;; Schedule @@ -435,40 +457,13 @@ Will produce (0 . 0) instead of a negative number, if needed." ;;; Asynchronous escape to run things ;;; ================================= -;; The future's in futures - -(define (make-future call-first on-success on-fail on-error) - ;; TODO: add error stuff here - (lambda () - (let ((call-result (call-first))) - ;; queue up calling the - (run (on-success call-result))))) - -(define (agenda-on-error agenda) - (const #f)) - -(define (agenda-on-fail agenda) - (const #f)) - -(define* (request-future call-first on-success - #:key - (agenda (%current-agenda)) - (on-fail (agenda-on-fail agenda)) - (on-error (agenda-on-error agenda)) - (when #f)) - ;; TODO: error handling - ;; do we need some distinction between expected, catchable errors, - ;; and unexpected, uncatchable ones? Probably...? - (make-run-request - (make-future call-first on-success on-fail on-error) - when)) - (define-syntax-rule (%8sync async-request) "Run BODY asynchronously at a prompt, passing args to make-future. Runs things asynchronously (8synchronously?)" - (abort-to-prompt (current-agenda-prompt) - async-request)) + (propagate-%async-exceptions + (abort-to-prompt (current-agenda-prompt) + async-request))) ;; Async port request and run-request meta-requests (define (make-async-request proc) @@ -489,16 +484,62 @@ return the wrong thing via (%8sync) and trip themselves up." "Invalid request passed back via an (%8sync) procedure." async-request)))) +(define-record-type + (make-wrapped-exception key args stacks) + wrapped-exception? + (key wrapped-exception-key) + (args wrapped-exception-args) + (stacks wrapped-exception-stacks)) + +(define-syntax-rule (propagate-%async-exceptions body) + (let ((body-result body)) + (if (wrapped-exception? body-result) + (throw '8sync-caught-error + (wrapped-exception-key body-result) + (wrapped-exception-args 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 - (begin body ...))) + ;; 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) @@ -518,11 +559,21 @@ return the wrong thing via (%8sync) and trip themselves up." (lambda () body ...))))) -;; Aliases -(define-syntax-rule (8run args ...) (%run args ...)) -(define-syntax-rule (8run-at args ...) (%run-at args ...)) -(define-syntax-rule (8run-delay args ...) (%run-delay args ...)) -(define-syntax-rule (8port-request args ...) (%port-request args ...)) +(define-syntax-rule (catch-8sync exp (handler-key handler) ...) + (catch '8sync-caught-error + (lambda () + exp) + (lambda (_ orig-key orig-args orig-stacks) + (cond + ((or (eq? handler-key #t) + (eq? orig-key handler-key)) + (apply handler orig-stacks orig-args)) ... + (else (raise '8sync-caught-error + orig-key orig-args orig-stacks)))))) + +;; Alias...? +(define-syntax-rule (catch-%8sync rest ...) + (catch-8sync rest ...)) @@ -656,13 +707,29 @@ return the wrong thing via (%8sync) and trip themselves up." (agenda-queue agenda)) (loop agenda)))))) -(define (print-error-and-continue . args) +(define (print-error-and-continue key . args) "Frequently used as pre-unwind-handler for agenda" - (format (current-error-port) "\n*** Caught exception with arguments: ~s ***\n" - args) - (display-backtrace (make-stack #t 1 0) - (current-error-port)) - (newline (current-error-port))) + (cond + ((eq? key '8sync-caught-error) + (match args + ((orig-key orig-args stacks) + (display "\n*** Caught async exception. ***\n") + (format (current-error-port) + "* Original key '~s and arguments: ~s *\n" + orig-key orig-args) + (display "* Caught stacks below (ending with original) *\n\n") + (for-each + (lambda (s) + (display-backtrace s (current-error-port)) + (newline (current-error-port))) + stacks)))) + (else + (format (current-error-port) + "\n*** Caught exception with key '~s and arguments: ~s ***\n" + key args) + (display-backtrace (make-stack #t 1 0) + (current-error-port)) + (newline (current-error-port))))) (define-syntax-rule (maybe-catch-all (catch-handler pre-unwind-handler) body ...)