X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=eightsync%2Fagenda.scm;h=ba075361339f469d9047c1df0eefc3d9f36963a2;hp=13cb95de3b16b90b94eedda8a45b4c97a26766ec;hb=a0fd0a50a742438b2c4ff5f06e684a84a5c863ca;hpb=a7bc314242cab78532f2a6b18ceb5863cfc863ef diff --git a/eightsync/agenda.scm b/eightsync/agenda.scm index 13cb95d..ba07536 100644 --- a/eightsync/agenda.scm +++ b/eightsync/agenda.scm @@ -64,8 +64,9 @@ run-it wrap wrap-apply run run-at run-delay %port-request %run %run-at %run-delay - 8port-request 8run 8run-at 8run-delay + print-error-and-continue + %current-agenda start-agenda agenda-run-once)) @@ -93,7 +94,7 @@ (define-immutable-record-type (make-agenda-intern queue prompt-tag read-port-map write-port-map except-port-map - schedule time) + schedule time catch-handler pre-unwind-handler) agenda? (queue agenda-queue) (prompt-tag agenda-prompt-tag) @@ -101,7 +102,9 @@ (write-port-map agenda-write-port-map) (except-port-map agenda-except-port-map) (schedule agenda-schedule) - (time agenda-time)) + (time agenda-time) + (catch-handler agenda-catch-handler) + (pre-unwind-handler agenda-pre-unwind-handler)) (define (make-async-prompt-tag) "Make an async prompt tag for an agenda. @@ -116,12 +119,15 @@ Generally done automatically for the user through (make-agenda)." (write-port-map (make-hash-table)) (except-port-map (make-hash-table)) (schedule (make-schedule)) - (time (gettimeofday))) + (time (gettimeofday)) + (catch-handler #f) + (pre-unwind-handler #f)) ;; TODO: document arguments "Make a fresh agenda." (make-agenda-intern queue prompt read-port-map write-port-map except-port-map - schedule time)) + schedule time + catch-handler pre-unwind-handler)) (define (current-agenda-prompt) "Get the prompt for the current agenda; signal an error if there isn't one." @@ -428,40 +434,19 @@ 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) @@ -482,16 +467,55 @@ 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 stack) + wrapped-exception? + (key wrapped-exception-key) + (args wrapped-exception-args) + (stack wrapped-exception-stack)) + +(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-stack 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 + ;; @@: For this stack to work doesn't it have to be + (lambda (key . args) + (make-wrapped-exception key args + exception-stack)) + (lambda _ + (set! exception-stack (make-stack #t 1 0))))))) when)))) (define-syntax-rule (%run-delay body ... delay-time) @@ -511,12 +535,6 @@ 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 ...)) - ;;; Execution of agenda, and current agenda @@ -649,6 +667,25 @@ return the wrong thing via (%8sync) and trip themselves up." (agenda-queue agenda)) (loop agenda)))))) +(define (print-error-and-continue . 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))) + +(define-syntax-rule (maybe-catch-all (catch-handler pre-unwind-handler) + body ...) + (if (or catch-handler pre-unwind-handler) + (catch + #t + (lambda () + body ...) + (or catch-handler (lambda _ #f)) + (or pre-unwind-handler (lambda _ #f))) + (begin body ...))) + (define (agenda-run-once agenda) "Run once through the agenda, and produce a new agenda based on the results" @@ -657,7 +694,10 @@ based on the results" (agenda-prompt-tag agenda) (lambda () (parameterize ((%current-agenda agenda)) - (proc))) + (maybe-catch-all + ((agenda-catch-handler agenda) + (agenda-pre-unwind-handler agenda)) + (proc)))) (lambda (kont async-request) (setup-async-request kont async-request))))