-;; 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
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.
(define-syntax-rule (propagate-%async-exceptions body)
(let ((body-result body))
(if (wrapped-exception? body-result)
- (throw '%8sync-caught-error
+ (throw '8sync-caught-error
(wrapped-exception-key body-result)
(wrapped-exception-args body-result)
(wrapped-exception-stacks body-result))
;; 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)
(cond
- ((eq? key '%8sync-caught-error)
+ ((eq? key '8sync-caught-error)
(match args
((orig-key orig-args orig-stacks)
(make-wrapped-exception
body ...)))))
(define-syntax-rule (catch-8sync exp (handler-key handler) ...)
- (catch '%8sync-caught-error
+ (catch '8sync-caught-error
(lambda ()
exp)
(lambda (_ orig-key orig-args orig-stacks)
((or (eq? handler-key #t)
(eq? orig-key handler-key))
(apply handler orig-stacks orig-args)) ...
- (else (raise '%8sync-caught-error
+ (else (raise '8sync-caught-error
orig-key orig-args orig-stacks))))))
;; Alias...?
(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 ...)