syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

cleanups and improvements

This commit is contained in:
Sam Caldwell 2019-05-31 10:01:36 -04:00
parent d93dc085fe
commit 6b272ad3d3
3 changed files with 85 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
racket/typed/core-expressions.rkt
View File

@ -69,7 +69,7 @@
(⇒ ν-ep (~effs eps1 ...)) (⇒ ν-f (~effs fs1 ...)) (⇒ ν-s (~effs ss1 ...))] (⇒ ν-ep (~effs eps1 ...)) (⇒ ν-f (~effs fs1 ...)) (⇒ ν-s (~effs ss1 ...))]
[⊢ e2 ≫ e2- (⇒ : τ2) [⊢ e2 ≫ e2- (⇒ : τ2)
(⇒ ν-ep (~effs eps2 ...)) (⇒ ν-f (~effs fs2 ...)) (⇒ ν-s (~effs ss2 ...))] (⇒ ν-ep (~effs eps2 ...)) (⇒ ν-f (~effs fs2 ...)) (⇒ ν-s (~effs ss2 ...))]
#:with τ (type-eval #'(U τ1 τ2)) #:with τ (mk-U- #'(τ1 τ2))
-------- --------
[⊢ (if- e_tst- e1- e2-) (⇒ : τ) [⊢ (if- e_tst- e1- e2-) (⇒ : τ)
(⇒ ν-ep (eps1 ... eps2 ...)) (⇒ ν-ep (eps1 ... eps2 ...))
@ -286,20 +286,18 @@
#:when (stx-length=? #'(p ...) #'(tt ...)) #:when (stx-length=? #'(p ...) #'(tt ...))
#t] #t]
[_ #f])) [_ #f]))
(define selected
(syntax-parse ty
[tt
#:when (matching? ty)
#'tt]
[(~U* (~or (~and tt (~fail #:unless (matching? #'tt)))
_) ...)
(mk-U- #'(tt ...))]))
(define (proj t i) (define (proj t i)
(syntax-parse t (syntax-parse t
[(~Tuple tt ...) [(~Tuple tt ...)
(stx-list-ref #'(tt ...) i)] (if (= i -1)
[(~U* tt ...) t
(mk-U- (stx-map (lambda (x) (proj x i)) #'(tt ...)))])) (stx-list-ref #'(tt ...) i))]
[(~U* (~or (~and tt (~fail #:unless (or (U*? #'tt) (matching? #'tt))))
_) ...)
(mk-U- (stx-map (lambda (x) (proj x i)) #'(tt ...)))]
[_
(mk-U*- '())]))
(define selected (proj ty -1))
(define sub-pats (define sub-pats
(for/list ([pat (in-syntax #'(p ...))] (for/list ([pat (in-syntax #'(p ...))]
[i (in-naturals)]) [i (in-naturals)])
@ -315,20 +313,18 @@
#:when (stx-length=? #'(p ...) #'(tt ...)) #:when (stx-length=? #'(p ...) #'(tt ...))
#t] #t]
[_ #f])) [_ #f]))
(define selected
(syntax-parse ty
[tt
#:when (matching? ty)
#'tt]
[(~U* (~or (~and tt (~fail #:unless (matching? #'tt)))
_) ...)
(mk-U- #'(tt ...))]))
(define (proj t i) (define (proj t i)
(syntax-parse t (syntax-parse t
[(~constructor-type _ tt ...) [(~constructor-type _ tt ...)
(stx-list-ref #'(tt ...) i)] (if (= i -1)
[(~U* tt ...) t
(mk-U- (stx-map (lambda (x) (proj x i)) #'(tt ...)))])) (stx-list-ref #'(tt ...) i))]
[(~U* (~or (~and tt (~fail #:unless (or (U*? #'tt) (matching? #'tt))))
_) ...)
(mk-U- (stx-map (lambda (x) (proj x i)) #'(tt ...)))]
[_
(mk-U*- '())]))
(define selected (proj ty -1))
(define sub-pats (define sub-pats
(for/list ([pat (in-syntax #'(p ...))] (for/list ([pat (in-syntax #'(p ...))]
[i (in-naturals)]) [i (in-naturals)])

143
racket/typed/core-types.rkt
View File

@ -46,24 +46,19 @@
(begin-for-syntax (begin-for-syntax
(struct type-metadata (isec cons) #:transparent) (struct type-metadata (isec cons) #:transparent)
;; (IdTable type-metadata)
(define TypeInfo# (make-free-id-table))
;; (MutableHashOf Symbol type-metadata) ;; (MutableHashOf Symbol type-metadata)
(define TypeInfo#* (make-hash)) (define TypeInfo# (make-hash))
;; Identifier isect-desc TypeCons -> Void ;; Identifier isect-desc TypeCons -> Void
(define (set-type-info! ty-cons isec cons) (define (set-type-info! ty-cons isec cons)
(free-id-table-set! TypeInfo# (when (hash-has-key? TypeInfo# ty-cons)
ty-cons
(type-metadata isec cons)))
(define (set-type-info!* ty-cons isec cons)
(when (hash-has-key? TypeInfo#* ty-cons)
;; TODO ;; TODO
#f) #f)
(hash-set! TypeInfo#* (hash-set! TypeInfo#
ty-cons ty-cons
(type-metadata isec cons))) (type-metadata isec cons)))
;; Identifier -> Symbol ;; Identifier -> Symbol
;; XYZ-.* ;; XYZ-.*
;; based on the convention used by turnstile *shrug*
(define (un- id) (define (un- id)
(define match? (define match?
(regexp-match #px"^(\\S*)-\\S*$" (symbol->string (syntax-e id)))) (regexp-match #px"^(\\S*)-\\S*$" (symbol->string (syntax-e id))))
@ -71,9 +66,7 @@
;; Identifier -> (U #f type-metadata) ;; Identifier -> (U #f type-metadata)
(define (get-type-info ty-cons) (define (get-type-info ty-cons)
(free-id-table-ref TypeInfo# ty-cons #f)) (hash-ref TypeInfo# (un- ty-cons) #f))
(define (get-type-info* ty-cons)
(hash-ref TypeInfo#* (un- ty-cons) #f))
;; Identifier -> (U #f isec-desc) ;; Identifier -> (U #f isec-desc)
(define (get-type-isec-desc ty-cons) (define (get-type-isec-desc ty-cons)
@ -83,14 +76,6 @@
(define (get-type-cons ty-cons) (define (get-type-cons ty-cons)
(define result? (get-type-info ty-cons)) (define result? (get-type-info ty-cons))
(and result? (type-metadata-cons result?))) (and result? (type-metadata-cons result?)))
;; Identifier -> (U #f isec-desc)
(define (get-type-isec-desc* ty-cons)
(define result? (get-type-info* ty-cons))
(and result? (type-metadata-isec result?)))
;; Identifier -> (U #f TypeCons)
(define (get-type-cons* ty-cons)
(define result? (get-type-info* ty-cons))
(and result? (type-metadata-cons result?)))
;; a isect-desc describes how a type (constructor) behaves with respect to ;; a isect-desc describes how a type (constructor) behaves with respect to
;; intersection, and is one of ;; intersection, and is one of
@ -128,13 +113,13 @@
;; Identifier -> Bool ;; Identifier -> Bool
;; check if the type has a syntax property allowing us to create new instances ;; check if the type has a syntax property allowing us to create new instances
(define (reassemblable? t) (define (reassemblable? t)
(and (get-type-cons* t) #t)) (and (get-type-cons t) #t))
;; Identifier (Listof Type) -> Type ;; Identifier (Listof Type) -> Type
;; Create a new instance of the type with the given arguments ;; Create a new instance of the type with the given arguments
;; needs to have the type-cons-key ;; needs to have the type-cons-key
(define (reassemble-type ty args) (define (reassemble-type ty args)
(define tycons (get-type-cons* ty)) (define tycons (get-type-cons ty))
(unless tycons (unless tycons
(error "expected to find type-cons-key")) (error "expected to find type-cons-key"))
(tycons args))) (tycons args)))
@ -165,8 +150,7 @@
(syntax/loc stx (syntax/loc stx
(Name- t (... ...)))])) (Name- t (... ...)))]))
(begin-for-syntax (begin-for-syntax
#;(set-type-info! #'Name- '#,(attribute desc.val) #'mk-) (set-type-info! 'Name '#,(attribute desc.val) mk-)
(set-type-info!* 'Name '#,(attribute desc.val) mk-)
(define-syntax NamePat (define-syntax NamePat
(pattern-expander (pattern-expander
(syntax-parser (syntax-parser
@ -667,7 +651,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-for-syntax (bot? t) (define-for-syntax (bot? t)
((current-typecheck-relation) t (type-eval #'(U*)))) ((current-typecheck-relation) t (mk-U*- '())))
(define-for-syntax (flat-type? τ) (define-for-syntax (flat-type? τ)
(syntax-parse τ (syntax-parse τ
@ -677,49 +661,44 @@
[_ #t])) [_ #t]))
(define-for-syntax (strip-? t) (define-for-syntax (strip-? t)
(type-eval (syntax-parse t
(syntax-parse t [(~U* τ ...) (mk-U- (stx-map strip-? #'(τ ...)))]
[(~U* τ ...) #`(U #,@(stx-map strip-? #'(τ ...)))] [~★/t (type-eval #'★/t)]
[~★/t #'★/t] ;; since (Observe X) can match (Message X):
;; since (Observe X) can match (Message X): ;; doing this specifically for the intersection operation in the spawn rule, need to check other
;; doing this specifically for the intersection operation in the spawn rule, need to check other ;; uses
;; uses [(~Observe τ) (mk-U- (list #'τ (mk-Message- #'(τ))))]
[(~Observe τ) #'(U τ (Message τ))] [_ (mk-U*- '())]))
[_ #'(U*)])))
;; similar to strip- fns, but leave non-message types as they are ;; similar to strip- fns, but leave non-message types as they are
(define-for-syntax (prune-message t) (define-for-syntax (prune-message t)
(type-eval (syntax-parse t
(syntax-parse t [(~U* τ ...) (mk-U- (stx-map prune-message #'(τ ...)))]
[(~U* τ ...) #`(U #,@(stx-map prune-message #'(τ ...)))] [~★/t (type-eval #'★/t)]
[~★/t #'★/t] [(~Message τ) #'τ]
[(~Message τ) #'τ] [_ t]))
[_ t])))
(define-for-syntax (strip-inbound t) (define-for-syntax (strip-inbound t)
(type-eval (syntax-parse t
(syntax-parse t [(~U* τ ...) (mk-U- (stx-map strip-inbound #'(τ ...)))]
[(~U* τ ...) #`(U #,@(stx-map strip-inbound #'(τ ...)))] [~★/t (type-eval #'★/t)]
[~★/t #'★/t] [(~Inbound τ) #'τ]
[(~Inbound τ) #'τ] [_ (mk-U*- '())]))
[_ #'(U*)])))
(define-for-syntax (strip-outbound t) (define-for-syntax (strip-outbound t)
(type-eval (syntax-parse t
(syntax-parse t [(~U* τ ...) (mk-U- (stx-map strip-outbound #'(τ ...)))]
[(~U* τ ...) #`(U #,@(stx-map strip-outbound #'(τ ...)))] [~★/t (type-eval #'★/t)]
[~★/t #'★/t] [(~Outbound τ) #'τ]
[(~Outbound τ) #'τ] [_ (mk-U*- '())]))
[_ #'(U*)])))
(define-for-syntax (relay-interests t) (define-for-syntax (relay-interests t)
(type-eval (syntax-parse t
(syntax-parse t ;; TODO: probably need to `normalize` the result
;; TODO: probably need to `normalize` the result [(~U* τ ...) (mk-U- (stx-map relay-interests #'(τ ...)))]
[(~U* τ ...) #`(U #,@(stx-map relay-interests #'(τ ...)))] [~★/t (type-eval #'★/t)]
[~★/t #'★/t] [(~Observe (~Inbound τ)) (mk-Observe- #'(τ))]
[(~Observe (~Inbound τ)) #'(Observe τ)] [_ (mk-U*- '())]))
[_ #'(U*)])))
;; (SyntaxOf RoleType ...) -> (Syntaxof InputType OutputType SpawnType) ;; (SyntaxOf RoleType ...) -> (Syntaxof InputType OutputType SpawnType)
(define-for-syntax (analyze-roles rs) (define-for-syntax (analyze-roles rs)
@ -730,9 +709,9 @@
([r (in-syntax rs)]) ([r (in-syntax rs)])
(define-values (i o s) (analyze-role-input/output r)) (define-values (i o s) (analyze-role-input/output r))
(values (cons i is) (cons o os) (cons s ss)))) (values (cons i is) (cons o os) (cons s ss))))
#`(#,(type-eval #`(U #,@lis)) #`(#,(mk-U- lis)
#,(type-eval #`(U #,@los)) #,(mk-U- los)
#,(type-eval #`(U #,@lss)))) #,(mk-U- lss)))
;; Wanted test case, but can't use it bc it uses things defined for-syntax ;; Wanted test case, but can't use it bc it uses things defined for-syntax
#;(module+ test #;(module+ test
@ -753,12 +732,14 @@
[(~Actor τc) [(~Actor τc)
(values (mk-U*- '()) (mk-U*- '()) t)] (values (mk-U*- '()) (mk-U*- '()) t)]
[(~Sends τ-m) [(~Sends τ-m)
(values (mk-U*- '()) (type-eval #'(Message τ-m)) (mk-U*- '()))] (values (mk-U*- '()) (mk-Message- #'(τ-m)) (mk-U*- '()))]
[(~Role (name:id) [(~Role (name:id)
(~or (~Shares τ-s) (~or (~Shares τ-s)
(~Sends τ-m) (~Sends τ-m)
(~Reacts τ-if τ-then ...)) ... (~Reacts τ-if τ-then ...)) ...
(~and (~Role _ ...) sub-role) ...) (~and (~Role _ ...) sub-role) ...)
#:with (msg ...) (for/list ([m (in-syntax #'(τ-m ...))])
(mk-Message- (list m)))
(define-values (is os ss) (define-values (is os ss)
(for/fold ([ins '()] (for/fold ([ins '()]
[outs '()] [outs '()]
@ -767,9 +748,9 @@
(define-values (i o s) (analyze-role-input/output t)) (define-values (i o s) (analyze-role-input/output t))
(values (cons i ins) (cons o outs) (cons s spawns)))) (values (cons i ins) (cons o outs) (cons s spawns))))
(define pat-types (stx-map event-desc-type #'(τ-if ...))) (define pat-types (stx-map event-desc-type #'(τ-if ...)))
(values (type-eval #`(U #,@is #,@pat-types)) (values (mk-U- #`(#,@is #,@pat-types))
(type-eval #`(U τ-s ... (Message τ-m) ... #,@os #,@(stx-map pattern-sub-type pat-types))) (mk-U- #`(τ-s ... msg ... #,@os #,@(stx-map pattern-sub-type pat-types)))
(type-eval #`(U #,@ss)))])) (mk-U- ss))]))
;; EventDescriptorType -> Type ;; EventDescriptorType -> Type
(define-for-syntax (event-desc-type desc) (define-for-syntax (event-desc-type desc)
@ -777,20 +758,20 @@
[(~Know τ) #'τ] [(~Know τ) #'τ]
[(~¬Know τ) #'τ] [(~¬Know τ) #'τ]
[(~Message τ) desc] [(~Message τ) desc]
[_ (type-eval #'(U*))])) [_ (mk-U*- '())]))
;; PatternType -> Type ;; PatternType -> Type
(define-for-syntax (pattern-sub-type pt) (define-for-syntax (pattern-sub-type pt)
(syntax-parse pt (syntax-parse pt
[(~Message τ) [(~Message τ)
(define t (replace-bind-and-discard-with-★ #'τ)) (define t (replace-bind-and-discard-with-★ #'τ))
(type-eval #`(Observe #,t))] (mk-Observe- (list t))]
[τ [τ
#:when (bot? #'τ) #:when (bot? #'τ)
#'τ] #'τ]
[τ [τ
(define t (replace-bind-and-discard-with-★ #'τ)) (define t (replace-bind-and-discard-with-★ #'τ))
(type-eval #`(Observe #,t))])) (mk-Observe- (list t))]))
;; TODO : can potentially use something like `subst` for this ;; TODO : can potentially use something like `subst` for this
(define-for-syntax (replace-bind-and-discard-with-★ t) (define-for-syntax (replace-bind-and-discard-with-★ t)
@ -929,15 +910,12 @@
[(~★/t _) [(~★/t _)
t2] t2]
[((~U* τ1:type ...) _) [((~U* τ1:type ...) _)
(type-eval #`(U #,@(stx-map (lambda (t) (∩ t t2)) #'(τ1 ...))))] (mk-U- (stx-map (lambda (t) (∩ t t2)) #'(τ1 ...)))]
[(_ (~U* τ2:type ...)) [(_ (~U* τ2:type ...))
(type-eval #`(U #,@(stx-map (lambda (t) (∩ t1 t)) #'(τ2 ...))))] (mk-U- (stx-map (lambda (t) (∩ t1 t)) #'(τ2 ...)))]
[(X:id Y:id) [(X:id Y:id)
#:when (free-identifier=? #'X #'Y) #:when (free-identifier=? #'X #'Y)
#'X] #'X]
[((~AssertionSet τ1) (~AssertionSet τ2))
#:with τ12 (∩ #'τ1 #'τ2)
(type-eval #'(AssertionSet τ12))]
;; Also, using <: is OK, even though <: refers to ∩, because <:'s use of ∩ is only ;; Also, using <: is OK, even though <: refers to ∩, because <:'s use of ∩ is only
;; in the Actor case. ;; in the Actor case.
[((~Base τ1:id) (~Base τ2:id)) [((~Base τ1:id) (~Base τ2:id))
@ -956,9 +934,9 @@
(reassemble-type #'τ-cons1 slots)] (reassemble-type #'τ-cons1 slots)]
[(== PRODUCT-LIKE) [(== PRODUCT-LIKE)
(if (ormap bot? slots) (if (ormap bot? slots)
(type-eval #'(U)) (mk-U*- '())
(reassemble-type #'τ-cons1 slots))])] (reassemble-type #'τ-cons1 slots))])]
[_ (type-eval #'(U))])) [_ (mk-U*- '())]))
;; Type Type -> Bool ;; Type Type -> Bool
;; first type is the contents of the set/dataspace ;; first type is the contents of the set/dataspace
@ -1016,7 +994,7 @@
[~Discard [~Discard
(type-eval #'★/t)] (type-eval #'★/t)]
[(~U* τ ...) [(~U* τ ...)
(type-eval #`(U #,@(stx-map pattern-matching-assertions #'(τ ...))))] (mk-U- (stx-map pattern-matching-assertions #'(τ ...)))]
[(~Any/bvs τ-cons () τ ...) [(~Any/bvs τ-cons () τ ...)
#:when (reassemblable? #'τ-cons) #:when (reassemblable? #'τ-cons)
(define subitems (for/list ([t (in-syntax #'(τ ...))]) (define subitems (for/list ([t (in-syntax #'(τ ...))])
@ -1568,14 +1546,3 @@
(stx-contains-id? #'ty X))) (stx-contains-id? #'ty X)))
(stx-map (λ _ irrelevant) Xs)] (stx-map (λ _ irrelevant) Xs)]
[_ (stx-map (λ _ invariant) Xs)]))) [_ (stx-map (λ _ invariant) Xs)])))
#;(begin-for-syntax
(define k (sixth (free-id-table-keys TypeInfo#)))
(define t
(syntax-parse (type-eval #'(Observe (Bind (Tuple))))
[(~Any/bvs cons () tt ...)
#'cons]))
(displayln k)
(displayln (hash-ref (syntax-debug-info k) 'bindings))
(displayln t)
(displayln (hash-ref (syntax-debug-info t) 'bindings)))

47
racket/typed/roles.rkt
View File

@ -159,7 +159,7 @@
(define-typed-syntax (assert e:expr) ≫ (define-typed-syntax (assert e:expr) ≫
[⊢ e ≫ e- (⇒ : τ)] [⊢ e ≫ e- (⇒ : τ)]
#:fail-unless (pure? #'e-) "expression not allowed to have effects" #:fail-unless (pure? #'e-) "expression not allowed to have effects"
#:with τs (type-eval #'(Shares τ)) #:with τs (mk-Shares- #'(τ))
------------------------------------- -------------------------------------
[⊢ (syndicate:assert e-) (⇒ : ★/t) [⊢ (syndicate:assert e-) (⇒ : ★/t)
(⇒ ν-ep (τs))]) (⇒ ν-ep (τs))])
@ -167,10 +167,10 @@
(define-typed-syntax (send! e:expr) ≫ (define-typed-syntax (send! e:expr) ≫
[⊢ e ≫ e- (⇒ : τ)] [⊢ e ≫ e- (⇒ : τ)]
#:fail-unless (pure? #'e-) "expression not allowed to have effects" #:fail-unless (pure? #'e-) "expression not allowed to have effects"
#:with τm (type-eval #'(Sends τ)) #:with τm (mk-Sends- #'(τ))
-------------------------------------- --------------------------------------
[⊢ (syndicate:send! e-) (⇒ : ★/t) [⊢ (#%app- syndicate:send! e-) (⇒ : ★/t)
(⇒ ν-f (τm))]) (⇒ ν-f (τm))])
(define-typed-syntax (stop facet-name:id cont ...) ≫ (define-typed-syntax (stop facet-name:id cont ...) ≫
[⊢ facet-name ≫ facet-name- (⇐ : FacetName)] [⊢ facet-name ≫ facet-name- (⇐ : FacetName)]
@ -234,7 +234,10 @@
[(on (a/r/m:asserted/retracted/message p) [(on (a/r/m:asserted/retracted/message p)
priority:priority priority:priority
s ...) ≫ s ...) ≫
#:with p/e (elaborate-pattern/with-com-ty #'p) #:do [(define msg? (free-identifier=? #'syndicate:message (attribute a/r/m.syndicate-kw)))
(define elab
(elaborate-pattern/with-com-ty (if msg? #'(message p) #'p)))]
#:with p/e (if msg? (stx-cadr elab) elab)
[⊢ p/e ≫ p-- (⇒ : τp)] [⊢ p/e ≫ p-- (⇒ : τp)]
#:fail-unless (pure? #'p--) "pattern not allowed to have effects" #:fail-unless (pure? #'p--) "pattern not allowed to have effects"
#:with ([x:id τ:type] ...) (pat-bindings #'p/e) #:with ([x:id τ:type] ...) (pat-bindings #'p/e)
@ -281,13 +284,12 @@
#:with (τ-i τ-o τ-a) (analyze-roles #'(τ-f ...)) #:with (τ-i τ-o τ-a) (analyze-roles #'(τ-f ...))
#:fail-unless (<: #'τ-o #'τ-c.norm) #:fail-unless (<: #'τ-o #'τ-c.norm)
(format "Output ~a not valid in dataspace ~a" (type->str #'τ-o) (type->str #'τ-c.norm)) (format "Output ~a not valid in dataspace ~a" (type->str #'τ-o) (type->str #'τ-c.norm))
#:fail-unless (<: #'τ-a #:with τ-final (mk-Actor- #'(τ-c.norm))
(type-eval #'(Actor τ-c.norm))) #:fail-unless (<: #'τ-a #'τ-final)
"Spawned actors not valid in dataspace" "Spawned actors not valid in dataspace"
#:fail-unless (project-safe? (∩ (strip-? #'τ-o) #'τ-c.norm) #:fail-unless (project-safe? (∩ (strip-? #'τ-o) #'τ-c.norm)
#'τ-i) #'τ-i)
"Not prepared to handle all inputs" "Not prepared to handle all inputs"
#:with τ-final (type-eval #'(Actor τ-c.norm))
-------------------------------------------------------------------------------------------- --------------------------------------------------------------------------------------------
[⊢ (syndicate:spawn (syndicate:on-start s-)) (⇒ : ★/t) [⊢ (syndicate:spawn (syndicate:on-start s-)) (⇒ : ★/t)
(⇒ ν-s (τ-final))]] (⇒ ν-s (τ-final))]]
@ -303,7 +305,7 @@
[ [
[⊢ s ≫ s- (⇒ ν-ep (~effs)) (⇒ ν-s (~effs τ-s ...)) (⇒ ν-f (~effs))] ... [⊢ s ≫ s- (⇒ ν-ep (~effs)) (⇒ ν-s (~effs τ-s ...)) (⇒ ν-f (~effs))] ...
] ]
#:with τ-actor (type-eval #'(Actor τ-c.norm)) #:with τ-actor (mk-Actor- #'(τ-c.norm))
#:fail-unless (stx-andmap (lambda (t) (<: t #'τ-actor)) #'(τ-s ... ...)) #:fail-unless (stx-andmap (lambda (t) (<: t #'τ-actor)) #'(τ-s ... ...))
"Not all actors conform to communication type" "Not all actors conform to communication type"
#:with τ-ds-i (strip-inbound #'τ-c.norm) #:with τ-ds-i (strip-inbound #'τ-c.norm)
@ -387,7 +389,6 @@
(set! x e0-) (set! x e0-)
remove.expr))]) remove.expr))])
;; TODO: #:on-add
(define-typed-syntax (define/query-set x:id p e (define-typed-syntax (define/query-set x:id p e
(~optional add:on-add) (~optional add:on-add)
(~optional remove:on-remove)) ≫ (~optional remove:on-remove)) ≫
@ -440,32 +441,6 @@
------------------------ ------------------------
[⊢ (#%app- x-) (⇒ : τ)]) [⊢ (#%app- x-) (⇒ : τ)])
;; it would be nice to abstract over these three
;; TODO - make the constructors
#;(define-typed-syntax (observe e:expr) ≫
[⊢ e ≫ e- (⇒ : τ)]
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
---------------------------------------------------------------------------
[⊢ (syndicate:observe e-) (⇒ : (Observe τ))])
#;(define-typed-syntax (inbound e:expr) ≫
[⊢ e ≫ e- (⇒ : τ)]
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
---------------------------------------------------------------------------
[⊢ (syndicate:inbound e-) (⇒ : (Inbound τ))])
#;(define-typed-syntax (outbound e:expr) ≫
[⊢ e ≫ e- (⇒ : τ)]
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
---------------------------------------------------------------------------
[⊢ (syndicate:outbound e-) (⇒ : (Outbound τ))])
#;(define-typed-syntax (message e:expr) ≫
[⊢ e ≫ e- (⇒ : τ)]
#:fail-unless (pure? #'e-) "expression must be pure"
------------------------------
[⊢ (syndicate:message e-) (⇒ : (Message τ))])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ground Dataspace ;; Ground Dataspace
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;