make-async-prompt-tag
+ list->q make-q*
+
<time-segment>
make-time-segment time-segment?
time-segment-time time-segment-queue
schedule-segments-split schedule-extract-until!
add-segments-contents-to-queue!
- %sync 8sync
+ %8sync
<run-request>
make-run-request run-request?
port-request-port
port-request-read port-request-write port-request-except
- run-it wrap run run-at run-delay
+ 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
start-agenda agenda-run-once))
(define-immutable-record-type <agenda>
(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)
(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.
(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."
"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))
\f
;;; Schedule
(lambda ()
body ...))
+(define-syntax-rule (wrap-apply body)
+ "Wrap possibly multi-value function in a procedure, applies all arguments"
+ (lambda args
+ (apply body args)))
+
+
;; @@: Do we really want `body ...' here?
;; what about just `body'?
(define-syntax-rule (run body ...)
;;; 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 (%sync async-request)
+(define-syntax-rule (%8sync async-request)
"Run BODY asynchronously at a prompt, passing args to make-future.
-Pronounced `eight-sync' despite the spelling.
-
-%sync was chosen because (async) was already taken and could lead to
-errors, and this version of asynchronous code uses a prompt, so the `a'
-character becomes a `%' prompt! :)
-
-The % and 8 characters kind of look similar... hence this library's
-name! (That, and the pun 'eight-synchronous' programming.)
-There are 8sync aliases if you prefer that name."
- (abort-to-prompt (current-agenda-prompt)
- async-request))
-
-(define-syntax-rule (8sync args ...)
- "Alias for %sync"
- (%sync args ...))
+Runs things asynchronously (8synchronously?)"
+ (propagate-%async-exceptions
+ (abort-to-prompt (current-agenda-prompt)
+ async-request)))
;; Async port request and run-request meta-requests
(define (make-async-request proc)
"Wrap PROC in an async-request
The purpose of this is to make sure that users don't accidentally
-return the wrong thing via (8sync) and trip themselves up."
+return the wrong thing via (%8sync) and trip themselves up."
(cons '*async-request* proc))
(define (setup-async-request resume-kont async-request)
;; TODO: deliver more helpful errors depending on what the user
;; returned
(_ (throw 'invalid-async-request
- "Invalid request passed back via an (%sync) procedure."
+ "Invalid request passed back via an (%8sync) procedure."
async-request))))
+(define-record-type <wrapped-exception>
+ (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)
(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 ...))
\f
(agenda-queue agenda))
(loop agenda))))))
+(define (print-error-and-continue key . args)
+ "Frequently used as pre-unwind-handler for agenda"
+ (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 ...)
+ (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"
(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))))
projects / 8sync.git / blobdiff