From 3452f1fe6ebfb410bd3c4e34d5b9642df6350225 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 9 Apr 2018 10:23:22 +0100
Subject: [PATCH] Script suspend and resume

---
 syndicate/dataspace.rkt | 41 ++++++++++++++++++++++++++++++++++++--
 syndicate/syntax.rkt    | 44 -----------------------------------------
 2 files changed, 39 insertions(+), 46 deletions(-)

diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt
index a41df54..61aae59 100644
--- a/syndicate/dataspace.rkt
+++ b/syndicate/dataspace.rkt
@@ -29,6 +29,7 @@
          current-facet
          in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
          capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt??
+         suspend-script* ;; TODO: shouldn't be provided - inline syntax.rkt??
 
          add-facet!
          stop-facet!
@@ -234,7 +235,9 @@
                                     (current-actor)
                                     (exn->string e))
                          (terminate-actor! ds a))]) ;; TODO: tracing
-        body ...
+        (call-with-syndicate-prompt
+         (lambda ()
+           body ...))
         (void)))))
 
 (define (capture-facet-context proc)
@@ -405,7 +408,7 @@
   (define eid (generate-id! ds))
   (define assertion
     (parameterize ((current-dataflow-subject-id (list f eid)))
-      (assertion-fn)))
+      (call-with-syndicate-prompt assertion-fn)))
   (define ep (endpoint eid assertion assertion-fn handler))
   (dataspace-assert! ds assertion)
   (when handler (dataspace-subscribe! ds handler))
@@ -446,6 +449,40 @@
   (ensure-in-script! 'dataspace-spawn!)
   (enqueue-action! ds (spawn name boot-proc initial-assertions)))
 
+;;---------------------------------------------------------------------------
+;; Script suspend-and-resume.
+
+(define prompt-tag (make-continuation-prompt-tag 'syndicate))
+
+(define (call-with-syndicate-prompt thunk)
+  (call-with-continuation-prompt thunk prompt-tag))
+
+(define (suspend-script* where proc)
+  (when (not (in-script?))
+    (error 'suspend-script
+           "~a: Cannot suspend script outside script; are you missing an (on ...)?"
+           where))
+  (call-with-composable-continuation
+   (lambda (k)
+     (abort-current-continuation
+      prompt-tag
+      (lambda ()
+        (define in? (in-script?))
+        (define raw-resume-parent
+          (capture-facet-context
+           (lambda results
+             (parameterize ((in-script? in?))
+               (apply k results)))))
+        (define resume-parent
+          (lambda results
+            (push-script! (current-dataspace)
+                          (lambda ()
+                            (apply raw-resume-parent results)))))
+        (proc resume-parent))))
+   prompt-tag))
+
+;;---------------------------------------------------------------------------
+
 (module+ test
   (message-struct set-box (new-value))
   (assertion-struct box-state (value))
diff --git a/syndicate/syntax.rkt b/syndicate/syntax.rkt
index 9725a4d..785f540 100644
--- a/syndicate/syntax.rkt
+++ b/syndicate/syntax.rkt
@@ -561,50 +561,6 @@
 ;;                         (define query-result (op query-result args ...)) ...
 ;;                         (on-start (flush!) (k (query-result) ...)))))]))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Script suspend-and-resume.
-
-(define prompt-tag (make-continuation-prompt-tag 'syndicate))
-
-(define (call-with-syndicate-effects thunk)
-  (call-with-continuation-prompt thunk prompt-tag))
-
-;; TODO: this is completely bogus -- it's the old Syndicate/rkt implementation. Needs rewriting
-(define (suspend-script* where proc)
-  (when (not (in-script?))
-    (error 'suspend-script
-           "~a: Cannot suspend script outside script; are you missing an (on ...)?"
-           where))
-  (call-with-composable-continuation
-   (lambda (k)
-     (abort-current-continuation
-      prompt-tag
-      (lambda ()
-        (define suspended-f (current-facet))
-        (define in? (in-script?))
-        (define stale? #f)
-        (define raw-resume-parent
-          (capture-facet-context
-           (lambda results
-             (parameterize ((in-script? in?))
-               (apply k results)))))
-        (define resume-parent
-          (lambda results
-            (when stale? (error 'suspend-script
-                                "Attempt to resume suspension (suspended at ~a) more than once"
-                                where))
-            (set! stale? #t)
-            (abort-current-continuation
-             prompt-tag
-             (lambda ()
-               (let ((invoking-f (current-facet)))
-                 (when (not (eq? invoking-f suspended-f))
-                   (terminate-facet! (current-dataspace) invoking-f)))
-               (push-script! (current-dataspace)
-                             (lambda () (apply raw-resume-parent results)))))))
-        (proc resume-parent))))
-   prompt-tag))
-
 (define (send! m)
   (dataspace-send! (current-dataspace) m))