-;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
-
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 3 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-;; 02110-1301 USA
+;;; 8sync --- Asynchronous programming for Guile
+;;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
+;;;
+;;; This file is part of 8sync.
+;;;
+;;; 8sync is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; 8sync is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
(define-module (eightsync agenda)
#:use-module (srfi srfi-1)
make-async-prompt-tag
+ list->q make-q*
+
<time-segment>
make-time-segment time-segment?
time-segment-time time-segment-queue
%port-request %run %run-at %run-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
"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
;;; Asynchronous escape to run things
;;; =================================
-(define (agenda-on-error agenda)
- (const #f))
-
-(define (agenda-on-fail agenda)
- (const #f))
-
(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)
async-request))))
(define-record-type <wrapped-exception>
- (make-wrapped-exception key args stack)
+ (make-wrapped-exception key args stacks)
wrapped-exception?
(key wrapped-exception-key)
(args wrapped-exception-args)
- (stack wrapped-exception-stack))
+ (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))
;; like evaluating immediately. Is that what we want?
(kont
;; Any unhandled errors are caught
- (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)
- (make-wrapped-exception key args
- (make-stack #t 1 0))))))
+ (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 ...)))))
+(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
;;; Execution of agenda, and current agenda
(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 ...)
projects / 8sync.git / blobdiff