From 00bf7d23641043fabbf0892a2535c50bc2ce7fb5 Mon Sep 17 00:00:00 2001
From: Sam Caldwell <samcaldwell@utexas.edu>
Date: Wed, 1 Aug 2018 11:30:25 -0400
Subject: [PATCH] during

---
 racket/typed/examples/roles/simple-during.rkt | 32 ++++++++++++++
 racket/typed/roles.rkt                        | 42 ++++++++++++++++++-
 2 files changed, 72 insertions(+), 2 deletions(-)
 create mode 100644 racket/typed/examples/roles/simple-during.rkt

diff --git a/racket/typed/examples/roles/simple-during.rkt b/racket/typed/examples/roles/simple-during.rkt
new file mode 100644
index 0000000..7faa029
--- /dev/null
+++ b/racket/typed/examples/roles/simple-during.rkt
@@ -0,0 +1,32 @@
+#lang typed/syndicate/roles
+
+;; Expected Output
+;; +GO
+;; +ready
+;; -GO
+;; -ready
+
+(define-type-alias ds-type
+  (U (Tuple String) (Observe (Tuple ★/t))))
+
+(dataspace ds-type
+  (spawn ds-type
+    (start-facet _
+      (fields)
+      (during (tuple "GO")
+        (assert (tuple "ready")))))
+  (spawn ds-type
+    (start-facet flag
+      (fields)
+      ;; type error when this was mistakenly just "GO"
+      (assert (tuple "GO"))
+      (on (asserted (tuple "ready"))
+          (stop flag))))
+  (spawn ds-type
+    (start-facet obs
+      (fields)
+      (during (tuple (bind s String))
+        (on start
+            (printf "+~a\n" s))
+        (on stop
+            (printf "-~a\n" s))))))
diff --git a/racket/typed/roles.rkt b/racket/typed/roles.rkt
index 3ebde04..d9b4e9e 100644
--- a/racket/typed/roles.rkt
+++ b/racket/typed/roles.rkt
@@ -11,6 +11,8 @@
          Observe Inbound Outbound Actor U
          ;; Statements
          let let* if spawn dataspace start-facet set! begin stop #;unsafe-do
+         ;; Derived Forms
+         during
          ;; endpoints
          assert on
          ;; expressions
@@ -754,13 +756,14 @@
     [_
      #'()]))
 
-(define-for-syntax (compile-pattern pat bind-id-transformer exp-transformer)
+;; TODO - figure out why this needs different list identifiers
+(define-for-syntax (compile-pattern pat list-binding bind-id-transformer exp-transformer)
     (define (l-e stx) (local-expand stx 'expression '()))
     (let loop ([pat pat])
       (syntax-parse pat
         #:datum-literals (tuple discard bind)
         [(tuple p ...)
-         #`(list 'tuple #,@(stx-map loop #'(p ...)))]
+         #`(#,list-binding 'tuple #,@(stx-map loop #'(p ...)))]
         [(k:kons1 p)
          #`(#,(kons1->constructor #'k) #,(loop #'p))]
         [(bind x:id τ:type)
@@ -777,11 +780,13 @@
 
 (define-for-syntax (compile-syndicate-pattern pat)
   (compile-pattern pat
+                   #'list-
                    (lambda (id) #`($ #,id))
                    identity))
 
 (define-for-syntax (compile-match-pattern pat)
   (compile-pattern pat
+                   #'list
                    identity
                    (lambda (exp) #`(==- #,exp))))
 
@@ -831,6 +836,39 @@
   ----------------------------------------------------
   [⊢ (x- e-) (⇒ : ★/t)])
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Derived Forms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-typed-syntax (during p s ...) ≫
+  #:with inst-p (instantiate-pattern #'p)
+  ----------------------------------------
+  [≻ (on (asserted p)
+         (start-facet during-inner
+           (fields)
+           (on (retracted inst-p)
+               (stop during-inner))
+           s ...))])
+
+;; TODO - reconcile this with `compile-pattern`
+(define-for-syntax (instantiate-pattern pat)
+  (let loop ([pat pat])
+    (syntax-parse pat
+      #:datum-literals (tuple discard bind)
+      [(tuple p ...)
+       #`(tuple #,@(stx-map loop #'(p ...)))]
+      [(k:kons1 p)
+       #`(k #,(loop #'p))]
+      [(bind x:id τ)
+       #'x]
+      [discard
+       #'_]
+      [(~constructor-exp ctor p ...)
+       (define/with-syntax uctor (untyped-ctor #'ctor))
+       #`(ctor #,@(stx-map loop #'(p ...)))]
+      [_
+       pat])))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Expressions
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;