X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=eightsync%2Fagenda.scm;h=5a2aea2bbc6ba4a148f44d5965ee43afc789aaca;hp=d02ce9fbdb029330308b852ad77ea0b84c66e405;hb=f6a77e5e588057731d5c4f98ae575a20936d4415;hpb=b338e79df344d5acc44bd6768eddba254ad59554 diff --git a/eightsync/agenda.scm b/eightsync/agenda.scm index d02ce9f..5a2aea2 100644 --- a/eightsync/agenda.scm +++ b/eightsync/agenda.scm @@ -1,19 +1,20 @@ -;; Copyright (C) 2015 Christopher Allan Webber - -;; 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 +;;; +;;; 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 . (define-module (eightsync agenda) #:use-module (srfi srfi-1) @@ -30,6 +31,8 @@ make-async-prompt-tag + list->q make-q* + make-time-segment time-segment? time-segment-time time-segment-queue @@ -65,6 +68,14 @@ %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 @@ -138,6 +149,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 @@ -434,12 +458,6 @@ Will produce (0 . 0) instead of a negative number, if needed." ;;; 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. @@ -468,20 +486,19 @@ return the wrong thing via (%8sync) and trip themselves up." async-request)))) (define-record-type - (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)) - (display "hi!\n") (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-stack body-result)) + (wrapped-exception-stacks body-result)) body-result))) (define-syntax-rule (%run body ...) @@ -511,10 +528,17 @@ return the wrong thing via (%8sync) and trip themselves up." ;; 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)) + (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)))) @@ -536,6 +560,22 @@ return the wrong thing via (%8sync) and trip themselves up." (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 ...)) + ;;; Execution of agenda, and current agenda @@ -668,13 +708,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 ...)