X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=loopy.scm;h=68dc0c1a843abd83c602668512413b7f5d66d8af;hb=38f30fa607340ea204900f022ee606feca5f12cb;hp=1d2352a9e1f18e97b42db38af32bceb7a922ae5f;hpb=8e2e5d59a50c5abcdf5a38ef2be7f306c0799007;p=8sync.git

diff --git a/loopy.scm b/loopy.scm
index 1d2352a..68dc0c1 100644
--- a/loopy.scm
+++ b/loopy.scm
@@ -37,7 +37,7 @@
             make-run-request run-request?
             run-request-proc run-request-when
 
-            run-it wrap run run-at delay
+            run-it wrap run run-at run-delay
 
             %current-agenda
             start-agenda agenda-run-once))
@@ -96,6 +96,15 @@ Generally done automatically for the user through (make-agenda)."
                       read-port-map write-port-map except-port-map
                       schedule time))
 
+(define (current-agenda-prompt)
+  "Get the prompt for the current agenda; signal an error if there isn't one."
+  (let ((current-agenda (%current-agenda)))
+    (if (not current-agenda)
+        (throw
+         'no-current-agenda
+         "Can't get current agenda prompt if there's no current agenda!")
+        (agenda-prompt-tag current-agenda))))
+
 
 
 ;;; Schedule
@@ -331,6 +340,8 @@ Will produce (0 . 0) instead of a negative number, if needed."
   (lambda ()
     body ...))
 
+;; @@: Do we really want `body ...' here?
+;;   what about just `body'?
 (define-syntax-rule (run body ...)
   "Run everything in BODY but wrap in a convenient procedure"
   (make-run-request (wrap body ...) #f))
@@ -339,15 +350,68 @@ Will produce (0 . 0) instead of a negative number, if needed."
   "Run BODY at WHEN"
   (make-run-request (wrap body ...) when))
 
+;; @@: Is it okay to overload the term "delay" like this?
+;;   Would `run-in' be better?
 (define-syntax-rule (run-delay body ... delay-time)
   "Run BODY at DELAY-TIME time from now"
   (make-run-request (wrap body ...) (tdelta delay-time)))
 
-(define (delay run-request delay-time)
-  "Delay a RUN-REQUEST by DELAY-TIME"
-  (set-field run-request
-             (run-request-when)
-             (tdelta delay-time)))
+
+
+;;; 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 body args ...)
+  "Run BODY asynchronously at a prompt, passing args to make-future.
+
+Pronounced `async' despite the spelling.
+
+8sync 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 :)"
+  (abort-to-prompt (current-agenda-prompt)
+                   (wrap body)
+                   args ...))
+
+(define-syntax-rule (%sync-at body when args ...)
+  (abort-to-prompt (current-agenda-prompt)
+                   (wrap body)
+                   #:when when
+                   args ...))
+
+(define-syntax-rule (%sync-delay body delay-time args ...)
+  (abort-to-prompt (current-agenda-prompt)
+                   (wrap body)
+                   #:when (tdelta delay-time)
+                   args ...))
 
 
 ;;; Execution of agenda, and current agenda
@@ -471,8 +535,9 @@ based on the results"
         (agenda-prompt-tag agenda)
       (lambda ()
         (proc))
-      ;; TODO
-      (lambda (k) k)))
+      (lambda* (resume-with please-run-this . args)
+        (apply request-future please-run-this resume-with
+               args))))
 
   (let ((queue (agenda-queue agenda))
         (next-queue (make-q)))