2018-07-25 21:26:47 +00:00
|
|
|
#lang turnstile
|
|
|
|
|
|
|
|
(provide (rename-out [syndicate:#%module-begin #%module-begin])
|
|
|
|
(rename-out [typed-app #%app])
|
|
|
|
#%top-interaction
|
|
|
|
require only-in
|
|
|
|
;; Types
|
2018-10-01 17:06:17 +00:00
|
|
|
(all-from-out "base-types.rkt")
|
2018-07-25 21:26:47 +00:00
|
|
|
;; Statements
|
2018-08-14 21:02:39 +00:00
|
|
|
let let* if spawn dataspace start-facet set! begin stop begin/dataflow #;unsafe-do
|
2018-09-12 21:03:19 +00:00
|
|
|
when unless send!
|
2018-08-01 15:30:25 +00:00
|
|
|
;; Derived Forms
|
2018-08-14 20:35:39 +00:00
|
|
|
during define/query-value define/query-set
|
2018-07-25 21:26:47 +00:00
|
|
|
;; endpoints
|
2018-08-08 19:20:09 +00:00
|
|
|
assert on field
|
2018-07-25 21:26:47 +00:00
|
|
|
;; expressions
|
2018-08-14 22:23:35 +00:00
|
|
|
tuple select lambda ref observe inbound outbound
|
2018-08-01 14:35:22 +00:00
|
|
|
;; making types
|
2018-10-02 18:01:55 +00:00
|
|
|
(all-from-out "user-ctors.rkt")
|
2018-07-25 21:26:47 +00:00
|
|
|
;; values
|
|
|
|
#%datum
|
|
|
|
;; patterns
|
|
|
|
bind discard
|
|
|
|
;; primitives
|
2018-10-02 18:01:55 +00:00
|
|
|
(except-out (all-from-out "define-like-things.rkt") define)
|
|
|
|
(rename-out [define/fun define])
|
2018-10-01 17:06:17 +00:00
|
|
|
(all-from-out "prim.rkt")
|
2018-10-02 18:01:55 +00:00
|
|
|
;; lists, sets
|
|
|
|
(all-from-out "list.rkt")
|
|
|
|
(all-from-out "set.rkt")
|
2018-07-25 21:26:47 +00:00
|
|
|
;; DEBUG and utilities
|
|
|
|
print-type print-role
|
|
|
|
;; Extensions
|
2018-07-31 18:03:15 +00:00
|
|
|
match cond
|
2018-09-14 20:40:43 +00:00
|
|
|
;; require & provides
|
|
|
|
require provide
|
2018-07-25 21:26:47 +00:00
|
|
|
)
|
|
|
|
|
|
|
|
(require (prefix-in syndicate: syndicate/actor-lang))
|
2018-10-01 17:06:17 +00:00
|
|
|
(require "base-types.rkt"
|
|
|
|
"effects.rkt"
|
|
|
|
"prim.rkt"
|
2018-10-02 18:01:55 +00:00
|
|
|
"judgments.rkt"
|
|
|
|
"user-ctors.rkt"
|
|
|
|
"list.rkt"
|
|
|
|
"set.rkt"
|
|
|
|
"define-like-things.rkt")
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(require (for-meta 2 macrotypes/stx-utils racket/list syntax/stx))
|
2018-10-01 17:06:17 +00:00
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
(require macrotypes/postfix-in)
|
2018-07-31 19:51:20 +00:00
|
|
|
(require (postfix-in - racket/match))
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(module+ test
|
|
|
|
(require rackunit)
|
|
|
|
(require turnstile/rackunit-typechecking))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Type Checking Conventions
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
;; : describes the immediate result of evaluation
|
2018-08-08 19:20:09 +00:00
|
|
|
;; ep key aggregates endpoint affects:
|
|
|
|
;; `Shares`, `Reacts`, and `MakesField`
|
|
|
|
;; Note thar MakesField is only an effect, not a type
|
2018-09-12 21:03:19 +00:00
|
|
|
;; f key aggregates facet effects (starting a facet) as `Role`s and message sends, `Sends`
|
2018-07-27 15:58:10 +00:00
|
|
|
;; s key aggregates spawned actors as `Actor`s
|
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
(define-for-syntax (type-eval t)
|
|
|
|
((current-type-eval) t))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Conveniences
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Syntax
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
(begin-for-syntax
|
|
|
|
|
|
|
|
;; constructors with arity one
|
|
|
|
(define-syntax-class kons1
|
|
|
|
(pattern (~or (~datum observe)
|
|
|
|
(~datum inbound)
|
2018-09-12 21:03:19 +00:00
|
|
|
(~datum outbound)
|
|
|
|
(~datum message))))
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define (kons1->constructor stx)
|
|
|
|
(syntax-parse stx
|
|
|
|
#:datum-literals (observe inbound outbound)
|
|
|
|
[observe #'syndicate:observe]
|
|
|
|
[inbound #'syndicate:inbound]
|
2018-09-12 21:03:19 +00:00
|
|
|
[outbound #'syndicate:outbound]
|
2018-10-01 17:06:17 +00:00
|
|
|
[message #'syndicate:message])))
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Utilities Over Types
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
(define-for-syntax (bot? t)
|
|
|
|
(<: t (type-eval #'(U*))))
|
|
|
|
|
|
|
|
(define-for-syntax (strip-inbound t)
|
|
|
|
(type-eval
|
|
|
|
(syntax-parse t
|
2018-09-12 21:03:19 +00:00
|
|
|
[(~U* τ ...) #`(U #,@(stx-map strip-inbound #'(τ ...)))]
|
2018-07-25 21:26:47 +00:00
|
|
|
[~★/t #'★/t]
|
|
|
|
[(~Inbound τ) #'τ]
|
|
|
|
[_ #'(U*)])))
|
|
|
|
|
|
|
|
(define-for-syntax (strip-outbound t)
|
|
|
|
(type-eval
|
|
|
|
(syntax-parse t
|
2018-09-12 21:03:19 +00:00
|
|
|
[(~U* τ ...) #`(U #,@(stx-map strip-outbound #'(τ ...)))]
|
2018-07-25 21:26:47 +00:00
|
|
|
[~★/t #'★/t]
|
|
|
|
[(~Outbound τ) #'τ]
|
|
|
|
[_ #'(U*)])))
|
|
|
|
|
|
|
|
(define-for-syntax (relay-interests t)
|
|
|
|
(type-eval
|
|
|
|
(syntax-parse t
|
|
|
|
;; TODO: probably need to `normalize` the result
|
2018-09-12 21:03:19 +00:00
|
|
|
[(~U* τ ...) #`(U #,@(stx-map relay-interests #'(τ ...)))]
|
2018-07-25 21:26:47 +00:00
|
|
|
[~★/t #'★/t]
|
|
|
|
[(~Observe (~Inbound τ)) #'(Observe τ)]
|
|
|
|
[_ #'(U*)])))
|
|
|
|
|
2018-07-31 19:51:20 +00:00
|
|
|
;; (SyntaxOf RoleType ...) -> (Syntaxof InputType OutputType SpawnType)
|
2018-07-27 21:16:44 +00:00
|
|
|
(define-for-syntax (analyze-roles rs)
|
2018-07-31 19:51:20 +00:00
|
|
|
(define-values (lis los lss)
|
2018-07-27 21:16:44 +00:00
|
|
|
(for/fold ([is '()]
|
2018-07-31 19:51:20 +00:00
|
|
|
[os '()]
|
|
|
|
[ss '()])
|
2018-07-27 21:16:44 +00:00
|
|
|
([r (in-syntax rs)])
|
2018-07-31 19:51:20 +00:00
|
|
|
(define-values (i o s) (analyze-role-input/output r))
|
|
|
|
(values (cons i is) (cons o os) (cons s ss))))
|
2018-07-27 21:16:44 +00:00
|
|
|
#`(#,(type-eval #`(U #,@lis))
|
2018-07-31 19:51:20 +00:00
|
|
|
#,(type-eval #`(U #,@los))
|
|
|
|
#,(type-eval #`(U #,@lss))))
|
2018-07-27 21:16:44 +00:00
|
|
|
|
|
|
|
;; Wanted test case, but can't use it bc it uses things defined for-syntax
|
|
|
|
#;(module+ test
|
|
|
|
(let ([r (type-eval #'(Role (x) (Shares Int)))])
|
|
|
|
(syntax-parse (analyze-role-input/output r)
|
|
|
|
[(τ-i τ-o)
|
|
|
|
(check-true (type=? #'τ-o (type-eval #'Int)))])))
|
|
|
|
|
2018-07-31 19:51:20 +00:00
|
|
|
;; RoleType -> (Values InputType OutputType SpawnType)
|
2018-07-27 14:24:46 +00:00
|
|
|
(define-for-syntax (analyze-role-input/output t)
|
|
|
|
(syntax-parse t
|
2018-07-31 18:03:15 +00:00
|
|
|
[(~Stop name:id τ-r ...)
|
2018-07-31 19:51:20 +00:00
|
|
|
#:with (τi τo τa) (analyze-roles #'(τ-r ...))
|
|
|
|
(values #'τi #'τo #'τa)]
|
|
|
|
[(~Actor τc)
|
|
|
|
(values (mk-U*- '()) (mk-U*- '()) t)]
|
2018-09-12 21:03:19 +00:00
|
|
|
[(~Sends τ-m)
|
|
|
|
(values (mk-U*- '()) (type-eval #'(Message τ-m)) (mk-U*- '()))]
|
2018-07-27 15:58:10 +00:00
|
|
|
[(~Role (name:id)
|
|
|
|
(~or (~Shares τ-s)
|
2018-09-12 21:03:19 +00:00
|
|
|
(~Sends τ-m)
|
2018-07-27 15:58:10 +00:00
|
|
|
(~Reacts τ-if τ-then ...)) ...
|
|
|
|
(~and (~Role _ ...) sub-role) ...)
|
2018-07-31 19:51:20 +00:00
|
|
|
(define-values (is os ss)
|
2018-07-27 21:16:44 +00:00
|
|
|
(for/fold ([ins '()]
|
2018-07-31 19:51:20 +00:00
|
|
|
[outs '()]
|
|
|
|
[spawns '()])
|
2018-07-27 21:16:44 +00:00
|
|
|
([t (in-syntax #'(τ-then ... ... sub-role ...))])
|
2018-07-31 19:51:20 +00:00
|
|
|
(define-values (i o s) (analyze-role-input/output t))
|
|
|
|
(values (cons i ins) (cons o outs) (cons s spawns))))
|
2018-07-27 21:16:44 +00:00
|
|
|
(define pat-types (stx-map event-desc-type #'(τ-if ...)))
|
|
|
|
(values (type-eval #`(U #,@is #,@pat-types))
|
2018-09-12 21:03:19 +00:00
|
|
|
(type-eval #`(U τ-s ... (Message τ-m) ... #,@os #,@(stx-map pattern-sub-type pat-types)))
|
2018-07-31 19:51:20 +00:00
|
|
|
(type-eval #`(U #,@ss)))]))
|
2018-07-27 21:16:44 +00:00
|
|
|
|
|
|
|
;; EventDescriptorType -> Type
|
|
|
|
(define-for-syntax (event-desc-type desc)
|
|
|
|
(syntax-parse desc
|
|
|
|
[(~Know τ) #'τ]
|
|
|
|
[(~¬Know τ) #'τ]
|
|
|
|
[(~Message τ) desc]
|
|
|
|
[_ (type-eval #'(U*))]))
|
|
|
|
|
|
|
|
;; PatternType -> Type
|
|
|
|
(define-for-syntax (pattern-sub-type pt)
|
2018-09-12 21:03:19 +00:00
|
|
|
(syntax-parse pt
|
|
|
|
[(~Message τ)
|
|
|
|
(define t (replace-bind-and-discard-with-★ #'τ))
|
|
|
|
(type-eval #`(Observe #,t))]
|
|
|
|
[τ
|
|
|
|
(define t (replace-bind-and-discard-with-★ #'τ))
|
|
|
|
(type-eval #`(Observe #,t))]))
|
2018-07-27 21:16:44 +00:00
|
|
|
|
|
|
|
(define-for-syntax (replace-bind-and-discard-with-★ t)
|
|
|
|
(syntax-parse t
|
|
|
|
[(~Bind _)
|
|
|
|
(type-eval #'★/t)]
|
|
|
|
[~Discard
|
|
|
|
(type-eval #'★/t)]
|
|
|
|
[(~U* τ ...)
|
|
|
|
(type-eval #`(U #,@(stx-map replace-bind-and-discard-with-★ #'(τ ...))))]
|
|
|
|
[(~Tuple τ ...)
|
|
|
|
(type-eval #`(Tuple #,@(stx-map replace-bind-and-discard-with-★ #'(τ ...))))]
|
|
|
|
[(~Observe τ)
|
|
|
|
(type-eval #`(Observe #,(replace-bind-and-discard-with-★ #'τ)))]
|
|
|
|
[(~Inbound τ)
|
|
|
|
(type-eval #`(Inbound #,(replace-bind-and-discard-with-★ #'τ)))]
|
|
|
|
[(~Outbound τ)
|
|
|
|
(type-eval #`(Outbound #,(replace-bind-and-discard-with-★ #'τ)))]
|
2018-09-12 21:03:19 +00:00
|
|
|
[(~Message τ)
|
|
|
|
(type-eval #`(Message #,(replace-bind-and-discard-with-★ #'τ)))]
|
2018-07-27 21:16:44 +00:00
|
|
|
[(~constructor-type _ τ ...)
|
|
|
|
(make-cons-type t (stx-map replace-bind-and-discard-with-★ #'(τ ...)))]
|
|
|
|
[_ t]))
|
2018-07-27 14:24:46 +00:00
|
|
|
|
2018-09-10 20:24:44 +00:00
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
;; MODIFYING GLOBAL TYPECHECKING STATE!!!!!
|
|
|
|
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
|
|
|
(begin-for-syntax
|
|
|
|
(current-typecheck-relation <:))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Core forms
|
2018-08-08 19:20:09 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-10-02 18:01:55 +00:00
|
|
|
|
2018-08-10 02:06:08 +00:00
|
|
|
|
2018-08-08 19:20:09 +00:00
|
|
|
(define-typed-syntax (start-facet name:id ep ...+) ≫
|
|
|
|
#:with name- (syntax-local-identifier-as-binding (syntax-local-introduce (generate-temporary #'name)))
|
|
|
|
#:with name+ (syntax-local-identifier-as-binding #'name)
|
|
|
|
#:with facet-name-ty (type-eval #'FacetName)
|
|
|
|
#:do [(define ctx (syntax-local-make-definition-context))
|
|
|
|
(define unique (gensym 'start-facet))
|
|
|
|
(define name-- (internal-definition-context-introduce ctx #'name- 'add))
|
2018-08-10 01:42:20 +00:00
|
|
|
(int-def-ctx-bind-type-rename #'name+ #'name- #'facet-name-ty ctx)
|
2018-08-10 02:06:08 +00:00
|
|
|
(define-values (ep-... τ... ep-effects facet-effects spawn-effects)
|
|
|
|
(walk/bind #'(ep ...) ctx unique))
|
|
|
|
(unless (and (stx-null? facet-effects) (stx-null? spawn-effects))
|
|
|
|
(type-error #:src #'(ep ...) #:msg "only endpoint effects allowed"))]
|
2018-08-08 19:20:09 +00:00
|
|
|
#:with ((~or (~and τ-a (~Shares _))
|
2018-09-12 21:03:19 +00:00
|
|
|
;; untyped syndicate might allow this - TODO
|
|
|
|
#;(~and τ-m (~Sends _))
|
2018-08-10 02:06:08 +00:00
|
|
|
(~and τ-r (~Reacts _ ...))
|
|
|
|
~MakesField)
|
2018-08-08 19:20:09 +00:00
|
|
|
...)
|
2018-08-10 02:06:08 +00:00
|
|
|
ep-effects
|
2018-08-08 19:20:09 +00:00
|
|
|
#:with τ (type-eval #`(Role (#,name--)
|
|
|
|
τ-a ...
|
2018-09-12 21:03:19 +00:00
|
|
|
;; τ-m ...
|
2018-08-08 19:20:09 +00:00
|
|
|
τ-r ...))
|
2018-07-25 21:26:47 +00:00
|
|
|
--------------------------------------------------------------
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ (syndicate:react (let- ([#,name-- (syndicate:current-facet-id)])
|
2018-08-10 02:06:08 +00:00
|
|
|
#,@ep-...))
|
2018-07-25 21:26:47 +00:00
|
|
|
(⇒ : ★/t)
|
2018-07-27 14:24:46 +00:00
|
|
|
(⇒ f (τ))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-08-08 19:20:09 +00:00
|
|
|
(define-typed-syntax (field [x:id τ-f:type e:expr] ...) ≫
|
|
|
|
#:fail-unless (stx-andmap flat-type? #'(τ-f ...)) "keep your uppity data outta my fields"
|
|
|
|
[⊢ e ≫ e- (⇐ : τ-f)] ...
|
|
|
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "field initializers not allowed to have effects"
|
|
|
|
#:with (x- ...) (generate-temporaries #'(x ...))
|
|
|
|
#:with (τ ...) (stx-map type-eval #'((Field τ-f.norm) ...))
|
2018-08-10 01:02:24 +00:00
|
|
|
#:with MF (type-eval #'MakesField)
|
2018-08-08 19:20:09 +00:00
|
|
|
----------------------------------------------------------------------
|
2018-08-10 01:02:24 +00:00
|
|
|
[⊢ (field/intermediate [x x- τ e-] ...)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ : ★/t)
|
|
|
|
(⇒ ep (MF))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax (assert e:expr) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
2018-08-08 19:20:09 +00:00
|
|
|
#:with τs (type-eval #'(Shares τ))
|
2018-07-25 21:26:47 +00:00
|
|
|
-------------------------------------
|
|
|
|
[⊢ (syndicate:assert e-) (⇒ : ★/t)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (τs))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-09-12 21:03:19 +00:00
|
|
|
(define-typed-syntax (send! e:expr) ≫
|
|
|
|
[⊢ e ≫ e- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
|
|
|
#:with τm (type-eval #'(Sends τ))
|
|
|
|
--------------------------------------
|
|
|
|
[⊢ (syndicate:send! e-) (⇒ : ★/t)
|
|
|
|
(⇒ f (τm))])
|
|
|
|
|
2018-07-31 18:03:15 +00:00
|
|
|
(define-typed-syntax (stop facet-name:id cont ...) ≫
|
2018-07-30 18:01:56 +00:00
|
|
|
[⊢ facet-name ≫ facet-name- (⇐ : FacetName)]
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ (begin #f cont ...) ≫ cont- (⇒ ep (~effs)) (⇒ s (~effs)) (⇒ f (~effs τ-f ...))]
|
2018-07-31 18:03:15 +00:00
|
|
|
#:with τ (mk-Stop- #`(facet-name- τ-f ...))
|
2018-07-30 18:01:56 +00:00
|
|
|
---------------------------------------------------------------------------------
|
|
|
|
[⊢ (syndicate:stop-facet facet-name- cont-) (⇒ : ★/t)
|
|
|
|
(⇒ f (τ))])
|
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
(begin-for-syntax
|
2018-09-12 21:03:19 +00:00
|
|
|
(define-syntax-class asserted/retracted/message
|
|
|
|
#:datum-literals (asserted retracted message)
|
2018-07-25 21:26:47 +00:00
|
|
|
(pattern (~or (~and asserted
|
|
|
|
(~bind [syndicate-kw #'syndicate:asserted]
|
|
|
|
[react-con #'Know]))
|
|
|
|
(~and retracted
|
|
|
|
(~bind [syndicate-kw #'syndicate:retracted]
|
2018-09-12 21:03:19 +00:00
|
|
|
[react-con #'¬Know]))
|
|
|
|
(~and message
|
|
|
|
(~bind [syndicate-kw #'syndicate:message]
|
|
|
|
[react-con #'Message]))))))
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax on
|
2018-07-31 19:51:20 +00:00
|
|
|
[(on (~literal start) s ...) ≫
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ (begin s ...) ≫ s- (⇒ ep (~effs))
|
2018-07-31 19:51:20 +00:00
|
|
|
(⇒ f (~effs τ-f ...))
|
|
|
|
(⇒ s (~effs τ-s ...))]
|
2018-08-08 19:20:09 +00:00
|
|
|
#:with τ-r (type-eval #'(Reacts OnStart τ-f ... τ-s ...))
|
2018-07-25 21:26:47 +00:00
|
|
|
-----------------------------------
|
2018-07-31 19:51:20 +00:00
|
|
|
[⊢ (syndicate:on-start s-) (⇒ : ★/t)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (τ-r))]]
|
2018-07-31 19:51:20 +00:00
|
|
|
[(on (~literal stop) s ...) ≫
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ (begin s ...) ≫ s- (⇒ ep (~effs))
|
2018-07-31 19:51:20 +00:00
|
|
|
(⇒ f (~effs τ-f ...))
|
|
|
|
(⇒ s (~effs τ-s ...))]
|
2018-08-08 19:20:09 +00:00
|
|
|
#:with τ-r (type-eval #'(Reacts OnStop τ-f ... τ-s ...))
|
2018-07-25 21:26:47 +00:00
|
|
|
-----------------------------------
|
2018-07-31 19:51:20 +00:00
|
|
|
[⊢ (syndicate:on-stop s-) (⇒ : ★/t)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (τ-r))]]
|
2018-09-12 21:03:19 +00:00
|
|
|
[(on (a/r/m:asserted/retracted/message p) s ...) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ p ≫ p-- (⇒ : τp)]
|
|
|
|
#:fail-unless (pure? #'p--) "pattern not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
#:with ([x:id τ:type] ...) (pat-bindings #'p)
|
2018-07-31 19:51:20 +00:00
|
|
|
[[x ≫ x- : τ] ... ⊢ (begin s ...) ≫ s-
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs))
|
2018-07-31 19:51:20 +00:00
|
|
|
(⇒ f (~effs τ-f ...))
|
|
|
|
(⇒ s (~effs τ-s ...))]
|
2018-07-31 18:46:24 +00:00
|
|
|
#:with p- (substs #'(x- ...) #'(x ...) (compile-syndicate-pattern #'p))
|
2018-09-12 21:03:19 +00:00
|
|
|
#:with τ-r (type-eval #'(Reacts (a/r/m.react-con τp) τ-f ... τ-s ...))
|
2018-07-25 21:26:47 +00:00
|
|
|
-----------------------------------
|
2018-09-12 21:03:19 +00:00
|
|
|
[⊢ (syndicate:on (a/r/m.syndicate-kw p-)
|
2018-07-31 18:46:24 +00:00
|
|
|
s-)
|
2018-07-25 21:26:47 +00:00
|
|
|
(⇒ : ★/t)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (τ-r))]])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-08-14 21:02:39 +00:00
|
|
|
(define-typed-syntax (begin/dataflow s ...+) ≫
|
|
|
|
[⊢ (begin s ...) ≫ s-
|
|
|
|
(⇒ : _)
|
|
|
|
(⇒ ep (~effs))
|
|
|
|
(⇒ f (~effs τ-f ...))
|
|
|
|
(⇒ s (~effs τ-s ...))]
|
|
|
|
#:with τ-r (type-eval #'(Reacts OnDataflow τ-f ... τ-s ...))
|
|
|
|
--------------------------------------------------
|
|
|
|
[⊢ (syndicate:begin/dataflow s-)
|
|
|
|
(⇒ : ★/t)
|
|
|
|
(⇒ ep (τ-r))])
|
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
;; pat -> ([Id Type] ...)
|
|
|
|
(define-for-syntax (pat-bindings stx)
|
|
|
|
(syntax-parse stx
|
|
|
|
#:datum-literals (bind tuple)
|
|
|
|
[(bind x:id τ:type)
|
|
|
|
#'([x τ])]
|
|
|
|
[(tuple p ...)
|
|
|
|
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
|
|
|
#'([x τ] ... ...)]
|
|
|
|
[(k:kons1 p)
|
|
|
|
(pat-bindings #'p)]
|
|
|
|
[(~constructor-exp cons p ...)
|
|
|
|
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
|
|
|
#'([x τ] ... ...)]
|
|
|
|
[_
|
|
|
|
#'()]))
|
|
|
|
|
2018-08-01 15:30:25 +00:00
|
|
|
;; TODO - figure out why this needs different list identifiers
|
|
|
|
(define-for-syntax (compile-pattern pat list-binding bind-id-transformer exp-transformer)
|
2018-07-31 18:46:24 +00:00
|
|
|
(define (l-e stx) (local-expand stx 'expression '()))
|
|
|
|
(let loop ([pat pat])
|
|
|
|
(syntax-parse pat
|
|
|
|
#:datum-literals (tuple discard bind)
|
|
|
|
[(tuple p ...)
|
2018-08-01 15:30:25 +00:00
|
|
|
#`(#,list-binding 'tuple #,@(stx-map loop #'(p ...)))]
|
2018-07-31 18:46:24 +00:00
|
|
|
[(k:kons1 p)
|
|
|
|
#`(#,(kons1->constructor #'k) #,(loop #'p))]
|
|
|
|
[(bind x:id τ:type)
|
|
|
|
(bind-id-transformer #'x)]
|
|
|
|
[discard
|
|
|
|
#'_]
|
|
|
|
[(~constructor-exp ctor p ...)
|
|
|
|
(define/with-syntax uctor (untyped-ctor #'ctor))
|
|
|
|
#`(uctor #,@(stx-map loop #'(p ...)))]
|
|
|
|
[_
|
|
|
|
;; local expanding "expression-y" syntax allows variable references to transform
|
|
|
|
;; according to the mappings set up by turnstile.
|
|
|
|
(exp-transformer (l-e pat))])))
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-for-syntax (compile-syndicate-pattern pat)
|
|
|
|
(compile-pattern pat
|
2018-08-01 15:30:25 +00:00
|
|
|
#'list-
|
2018-07-25 21:26:47 +00:00
|
|
|
(lambda (id) #`($ #,id))
|
|
|
|
identity))
|
|
|
|
|
2018-07-30 21:36:42 +00:00
|
|
|
(define-for-syntax (compile-match-pattern pat)
|
|
|
|
(compile-pattern pat
|
2018-08-01 15:30:25 +00:00
|
|
|
#'list
|
2018-07-30 21:36:42 +00:00
|
|
|
identity
|
2018-07-31 19:51:20 +00:00
|
|
|
(lambda (exp) #`(==- #,exp))))
|
2018-07-30 21:36:42 +00:00
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
(define-typed-syntax (spawn τ-c:type s) ≫
|
|
|
|
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
2018-07-30 18:01:56 +00:00
|
|
|
;; TODO: check that each τ-f is a Role
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ s ≫ s- (⇒ ep (~effs)) (⇒ s (~effs)) (⇒ f (~effs τ-f ...))]
|
2018-07-25 21:26:47 +00:00
|
|
|
;; TODO: s shouldn't refer to facets or fields!
|
2018-07-31 19:51:20 +00:00
|
|
|
#:with (τ-i τ-o τ-a) (analyze-roles #'(τ-f ...))
|
2018-07-27 21:16:44 +00:00
|
|
|
#:fail-unless (<: #'τ-o #'τ-c.norm)
|
|
|
|
(format "Output ~a not valid in dataspace ~a" (type->str #'τ-o) (type->str #'τ-c.norm))
|
2018-07-31 19:51:20 +00:00
|
|
|
#:fail-unless (<: #'τ-a
|
|
|
|
(type-eval #'(Actor τ-c.norm)))
|
|
|
|
"Spawned actors not valid in dataspace"
|
2018-07-27 21:16:44 +00:00
|
|
|
#:fail-unless (project-safe? (∩ (strip-? #'τ-o) #'τ-c.norm)
|
|
|
|
#'τ-i)
|
|
|
|
"Not prepared to handle all inputs"
|
2018-07-31 19:51:20 +00:00
|
|
|
#:with τ-final (type-eval #'(Actor τ-c.norm))
|
2018-07-25 21:26:47 +00:00
|
|
|
--------------------------------------------------------------------------------------------
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ (syndicate:spawn (syndicate:on-start s-)) (⇒ : ★/t)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ s (τ-final))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-07-30 15:54:05 +00:00
|
|
|
(define-typed-syntax (dataspace τ-c:type s ...) ≫
|
|
|
|
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ s ≫ s- (⇒ ep (~effs)) (⇒ s (~effs τ-s ...)) (⇒ f (~effs))] ...
|
2018-07-30 15:54:05 +00:00
|
|
|
#:with τ-actor (type-eval #'(Actor τ-c.norm))
|
|
|
|
#:fail-unless (stx-andmap (lambda (t) (<: t #'τ-actor)) #'(τ-s ... ...))
|
|
|
|
"Not all actors conform to communication type"
|
|
|
|
#:with τ-ds-i (strip-inbound #'τ-c.norm)
|
|
|
|
#:with τ-ds-o (strip-outbound #'τ-c.norm)
|
|
|
|
#:with τ-relay (relay-interests #'τ-c.norm)
|
|
|
|
-----------------------------------------------------------------------------------
|
|
|
|
[⊢ (syndicate:dataspace s- ...) (⇒ : ★/t)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ s ((Actor (U τ-ds-i τ-ds-o τ-relay))))])
|
2018-07-30 15:54:05 +00:00
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
(define-typed-syntax (set! x:id e:expr) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
[⊢ x ≫ x- (⇒ : (~Field τ-x:type))]
|
|
|
|
#:fail-unless (<: #'τ #'τ-x) "Ill-typed field write"
|
|
|
|
----------------------------------------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (x- e-) (⇒ : ★/t)])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-08-01 15:30:25 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Derived Forms
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
(define-typed-syntax (during p s ...) ≫
|
|
|
|
#:with inst-p (instantiate-pattern #'p)
|
|
|
|
----------------------------------------
|
|
|
|
[≻ (on (asserted p)
|
|
|
|
(start-facet during-inner
|
|
|
|
(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]
|
2018-08-13 23:32:23 +00:00
|
|
|
;; not sure about this
|
2018-08-01 15:30:25 +00:00
|
|
|
[discard
|
2018-08-13 23:32:23 +00:00
|
|
|
#'discard]
|
2018-08-01 15:30:25 +00:00
|
|
|
[(~constructor-exp ctor p ...)
|
|
|
|
(define/with-syntax uctor (untyped-ctor #'ctor))
|
|
|
|
#`(ctor #,@(stx-map loop #'(p ...)))]
|
|
|
|
[_
|
|
|
|
pat])))
|
|
|
|
|
2018-08-14 19:43:51 +00:00
|
|
|
(define-typed-syntax (define/query-value x:id e0 p e) ≫
|
|
|
|
[⊢ e0 ≫ e0- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e0-) "expression must be pure"
|
|
|
|
----------------------------------------
|
|
|
|
[≻ (begin (field [x τ e0-])
|
|
|
|
(on (asserted p)
|
|
|
|
(set! x e))
|
|
|
|
(on (retracted p)
|
|
|
|
(set! x e0-)))])
|
|
|
|
|
2018-08-14 22:23:35 +00:00
|
|
|
;; TODO: #:on-add
|
2018-08-14 20:35:39 +00:00
|
|
|
(define-typed-syntax (define/query-set x:id p e) ≫
|
|
|
|
#:with ([y τ] ...) (pat-bindings #'p)
|
|
|
|
;; e will be re-expanded :/
|
|
|
|
[[y ≫ y- : τ] ... ⊢ e ≫ e- ⇒ τ-e]
|
|
|
|
----------------------------------------
|
|
|
|
[≻ (begin (field [x (Set τ-e) (set)])
|
|
|
|
(on (asserted p)
|
|
|
|
(set! x (set-add (ref x) e)))
|
|
|
|
(on (retracted p)
|
|
|
|
(set! x (set-remove (ref x) e))))])
|
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Expressions
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
(define-typed-syntax (ref x:id) ≫
|
|
|
|
[⊢ x ≫ x- ⇒ (~Field τ)]
|
|
|
|
------------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (x-) (⇒ : τ)])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-07-30 21:00:42 +00:00
|
|
|
(define-typed-syntax (lambda ([x:id (~optional (~datum :)) τ:type] ...) body ...+) ≫
|
|
|
|
[[x ≫ x- : τ] ... ⊢ (begin body ...) ≫ body- (⇒ : τ-e)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs τ-ep ...))
|
2018-07-30 21:00:42 +00:00
|
|
|
(⇒ s (~effs τ-s ...))
|
|
|
|
(⇒ f (~effs τ-f ...))]
|
|
|
|
----------------------------------------
|
|
|
|
[⊢ (lambda- (x- ...) body-) (⇒ : (→ τ ... (Computation (Value τ-e)
|
2018-08-14 22:23:35 +00:00
|
|
|
(Endpoints τ-ep ...)
|
2018-07-30 21:00:42 +00:00
|
|
|
(Roles τ-f ...)
|
|
|
|
(Spawns τ-s ...))))])
|
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
(define-typed-syntax (typed-app e_fn e_arg ...) ≫
|
2018-07-30 21:00:42 +00:00
|
|
|
[⊢ e_fn ≫ e_fn- (⇒ : (~→ τ_in ... (~Computation (~Value τ-out)
|
2018-08-08 19:20:09 +00:00
|
|
|
(~Endpoints τ-ep ...)
|
2018-07-30 21:00:42 +00:00
|
|
|
(~Roles τ-f ...)
|
|
|
|
(~Spawns τ-s ...))))]
|
2018-07-27 15:37:22 +00:00
|
|
|
#:fail-unless (pure? #'e_fn-) "expression not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
#:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...])
|
|
|
|
(num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e_arg ≫ e_arg- (⇐ : τ_in)] ...
|
|
|
|
#:fail-unless (stx-andmap pure? #'(e_arg- ...)) "expressions not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
------------------------------------------------------------------------
|
2018-07-30 21:00:42 +00:00
|
|
|
[⊢ (#%app- e_fn- e_arg- ...) (⇒ : τ-out)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (τ-ep ...))
|
2018-07-30 21:00:42 +00:00
|
|
|
(⇒ s (τ-s ...))
|
|
|
|
(⇒ f (τ-f ...))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax (tuple e:expr ...) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ)] ...
|
|
|
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
-----------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (list- 'tuple e- ...) (⇒ : (Tuple τ ...))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax (select n:nat e:expr) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : (~Tuple τ ...))]
|
|
|
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
#:do [(define i (syntax->datum #'n))]
|
|
|
|
#:fail-unless (< i (stx-length #'(τ ...))) "index out of range"
|
|
|
|
#:with τr (list-ref (stx->list #'(τ ...)) i)
|
|
|
|
--------------------------------------------------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (tuple-select n e-) (⇒ : τr)])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define- (tuple-select n t)
|
|
|
|
(list-ref- t (add1 n)))
|
|
|
|
|
|
|
|
;; it would be nice to abstract over these three
|
|
|
|
(define-typed-syntax (observe e:expr) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
---------------------------------------------------------------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (syndicate:observe e-) (⇒ : (Observe τ))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax (inbound e:expr) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
---------------------------------------------------------------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (syndicate:inbound e-) (⇒ : (Inbound τ))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax (outbound e:expr) ≫
|
2018-07-27 15:37:22 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
2018-07-25 21:26:47 +00:00
|
|
|
---------------------------------------------------------------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (syndicate:outbound e-) (⇒ : (Outbound τ))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
2018-09-12 21:03:19 +00:00
|
|
|
(define-typed-syntax (message e:expr) ≫
|
|
|
|
[⊢ e ≫ e- (⇒ : τ)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression must be pure"
|
|
|
|
------------------------------
|
|
|
|
[⊢ (syndicate:message e-) (⇒ : (Message τ))])
|
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Patterns
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
(define-typed-syntax (bind x:id τ:type) ≫
|
|
|
|
----------------------------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (error- 'bind "escaped") (⇒ : (Bind τ))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax discard
|
|
|
|
[_ ≫
|
|
|
|
--------------------
|
2018-07-27 14:54:22 +00:00
|
|
|
[⊢ (error- 'discard "escaped") (⇒ : Discard)]])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Core-ish forms
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
2018-10-02 18:01:55 +00:00
|
|
|
;; add support for function definitions to define, otherwise falling back to `define` from
|
|
|
|
;; "define-like-things.rkt"
|
|
|
|
(define-typed-syntax define/fun
|
2018-08-14 22:23:35 +00:00
|
|
|
[(_ (f [x (~optional (~datum :)) ty:type] ...
|
|
|
|
(~or (~datum →) (~datum ->)) ty_out:type)
|
2018-08-13 23:32:23 +00:00
|
|
|
e ...+) ≫
|
|
|
|
[⊢ (lambda ([x : ty] ...) (begin e ...)) ≫ e- (⇒ : (~and fun-ty
|
2018-08-14 22:23:35 +00:00
|
|
|
(~→ (~not (~Computation _ ...)) ...
|
|
|
|
(~Computation (~Value τ-v)
|
|
|
|
_ ...))))]
|
|
|
|
#:fail-unless (<: #'τ-v #'ty_out.norm)
|
|
|
|
(format "expected different return type\n got ~a\n expected ~a\n"
|
2018-10-02 18:01:55 +00:00
|
|
|
(type->str #'τ-v)
|
|
|
|
(type->str #'ty_out))
|
2018-07-30 19:17:30 +00:00
|
|
|
#:with f- (add-orig (generate-temporary #'f) #'f)
|
|
|
|
--------
|
2018-08-14 22:23:35 +00:00
|
|
|
[⊢ (define/intermediate f f- fun-ty e-) (⇒ : ★/t)]]
|
|
|
|
[(_ (f [x (~optional (~datum :)) ty] ...)
|
|
|
|
e ...+) ≫
|
2018-09-12 19:06:08 +00:00
|
|
|
----------------------------
|
2018-10-02 18:01:55 +00:00
|
|
|
[≻ (define/fun (f [x ty] ... -> ★/t) e ...)]]
|
|
|
|
[(_ e ...+) ≫
|
|
|
|
---------------------------------------------
|
|
|
|
[≻ (define e ...)]])
|
|
|
|
|
|
|
|
;; copied from stlc
|
|
|
|
(define-typed-syntax (ann e (~optional (~datum :)) τ:type) ≫
|
|
|
|
[⊢ e ≫ e- (⇐ : τ.norm)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression must be pure"
|
|
|
|
------------------------------------------------
|
|
|
|
[⊢ e- (⇒ : τ.norm) ])
|
2018-07-30 19:17:30 +00:00
|
|
|
|
|
|
|
;; copied from ext-stlc
|
|
|
|
(define-typed-syntax if
|
|
|
|
[(_ e_tst e1 e2) ⇐ τ-expected ≫
|
|
|
|
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
|
|
|
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
|
|
|
[⊢ e1 ≫ e1- (⇐ : τ-expected)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps1 ...)) (⇒ f (~effs fs1 ...)) (⇒ s (~effs ss1 ...))]
|
2018-07-30 19:17:30 +00:00
|
|
|
[⊢ e2 ≫ e2- (⇐ : τ-expected)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps2 ...)) (⇒ f (~effs fs2 ...)) (⇒ s (~effs ss2 ...))]
|
2018-07-30 19:17:30 +00:00
|
|
|
--------
|
|
|
|
[⊢ (if- e_tst- e1- e2-)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (eps1 ... eps2 ...))
|
2018-07-31 18:03:15 +00:00
|
|
|
(⇒ f (fs1 ... fs2 ...))
|
|
|
|
(⇒ s (ss1 ... ss2 ...))]]
|
2018-07-30 19:17:30 +00:00
|
|
|
[(_ e_tst e1 e2) ≫
|
|
|
|
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
|
|
|
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
|
|
|
[⊢ e1 ≫ e1- (⇒ : τ1)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps1 ...)) (⇒ f (~effs fs1 ...)) (⇒ s (~effs ss1 ...))]
|
2018-07-30 19:17:30 +00:00
|
|
|
[⊢ e2 ≫ e2- (⇒ : τ2)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps2 ...)) (⇒ f (~effs fs2 ...)) (⇒ s (~effs ss2 ...))]
|
2018-07-30 19:17:30 +00:00
|
|
|
#:with τ (type-eval #'(U τ1 τ2))
|
|
|
|
--------
|
|
|
|
[⊢ (if- e_tst- e1- e2-) (⇒ : τ)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (eps1 ... eps2 ...))
|
2018-07-31 18:03:15 +00:00
|
|
|
(⇒ f (fs1 ... fs2 ...))
|
|
|
|
(⇒ s (ss1 ... ss2 ...))]])
|
2018-07-30 19:17:30 +00:00
|
|
|
|
2018-08-14 22:23:35 +00:00
|
|
|
(define-typed-syntax (when e s ...+) ≫
|
|
|
|
------------------------------------
|
|
|
|
[≻ (if e (begin s ...) #f)])
|
|
|
|
|
|
|
|
(define-typed-syntax (unless e s ...+) ≫
|
|
|
|
------------------------------------
|
|
|
|
[≻ (if e #f (begin s ...))])
|
|
|
|
|
2018-07-30 19:17:30 +00:00
|
|
|
;; copied from ext-stlc
|
|
|
|
(define-typed-syntax let
|
|
|
|
[(_ ([x e] ...) e_body ...) ⇐ τ_expected ≫
|
|
|
|
[⊢ e ≫ e- ⇒ : τ_x] ...
|
|
|
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
|
|
|
[[x ≫ x- : τ_x] ... ⊢ (begin e_body ...) ≫ e_body- (⇐ : τ_expected)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps ...))
|
2018-07-30 19:17:30 +00:00
|
|
|
(⇒ f (~effs fs ...))
|
|
|
|
(⇒ s (~effs ss ...))]
|
|
|
|
----------------------------------------------------------
|
|
|
|
[⊢ (let- ([x- e-] ...) e_body-)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (eps ...))
|
2018-07-31 18:03:15 +00:00
|
|
|
(⇒ f (fs ...))
|
|
|
|
(⇒ s (ss ...))]]
|
2018-07-30 19:17:30 +00:00
|
|
|
[(_ ([x e] ...) e_body ...) ≫
|
|
|
|
[⊢ e ≫ e- ⇒ : τ_x] ...
|
|
|
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
|
|
|
[[x ≫ x- : τ_x] ... ⊢ (begin e_body ...) ≫ e_body- (⇒ : τ_body)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps ...))
|
2018-07-30 19:17:30 +00:00
|
|
|
(⇒ f (~effs fs ...))
|
|
|
|
(⇒ s (~effs ss ...))]
|
|
|
|
----------------------------------------------------------
|
|
|
|
[⊢ (let- ([x- e-] ...) e_body-) (⇒ : τ_body)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (eps ...))
|
2018-07-31 18:03:15 +00:00
|
|
|
(⇒ f (fs ...))
|
|
|
|
(⇒ s (ss ...))]])
|
2018-07-30 19:17:30 +00:00
|
|
|
|
|
|
|
;; copied from ext-stlc
|
|
|
|
(define-typed-syntax let*
|
|
|
|
[(_ () e_body ...) ≫
|
|
|
|
--------
|
|
|
|
[≻ (begin e_body ...)]]
|
|
|
|
[(_ ([x e] [x_rst e_rst] ...) e_body ...) ≫
|
|
|
|
--------
|
|
|
|
[≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body ...))]])
|
|
|
|
|
2018-07-30 21:36:42 +00:00
|
|
|
(define-typed-syntax (cond [pred:expr s ...+] ...+) ≫
|
|
|
|
[⊢ pred ≫ pred- (⇐ : Bool)] ...
|
|
|
|
#:fail-unless (stx-andmap pure? #'(pred- ...)) "predicates must be pure"
|
|
|
|
[⊢ (begin s ...) ≫ s- (⇒ : τ-s)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps ...))
|
2018-07-30 21:36:42 +00:00
|
|
|
(⇒ f (~effs fs ...))
|
|
|
|
(⇒ s (~effs ss ...))] ...
|
|
|
|
------------------------------------------------
|
|
|
|
[⊢ (cond- [pred- s-] ...) (⇒ : (U τ-s ...))
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (eps ... ...))
|
2018-07-30 21:36:42 +00:00
|
|
|
(⇒ f (fs ... ...))
|
|
|
|
(⇒ s (ss ... ...))])
|
|
|
|
|
|
|
|
(define-typed-syntax (match e [p s ...+] ...+) ≫
|
|
|
|
[⊢ e ≫ e- (⇒ : τ-e)]
|
|
|
|
#:fail-unless (pure? #'e-) "expression must be pure"
|
|
|
|
#:with (([x τ] ...) ...) (stx-map pat-bindings #'(p ...))
|
|
|
|
[[x ≫ x- : τ] ... ⊢ (begin s ...) ≫ s- (⇒ : τ-s)
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (~effs eps ...))
|
2018-07-30 21:36:42 +00:00
|
|
|
(⇒ f (~effs fs ...))
|
|
|
|
(⇒ s (~effs ss ...))] ...
|
|
|
|
;; REALLY not sure how to handle p/p-/p.match-pattern,
|
|
|
|
;; particularly w.r.t. typed terms that appear in p.match-pattern
|
|
|
|
[⊢ p ≫ p-- ⇒ τ-p] ...
|
|
|
|
#:fail-unless (project-safe? #'τ-e (type-eval #'(U τ-p ...))) "possibly unsafe pattern match"
|
|
|
|
#:fail-unless (stx-andmap pure? #'(p-- ...)) "patterns must be pure"
|
2018-07-31 18:46:24 +00:00
|
|
|
#:with (p- ...) (stx-map (lambda (p x-s xs) (substs x-s xs (compile-match-pattern p)))
|
|
|
|
#'(p ...)
|
|
|
|
#'((x- ...) ...)
|
|
|
|
#'((x ...) ...))
|
2018-07-30 21:36:42 +00:00
|
|
|
--------------------------------------------------------------
|
2018-07-31 18:46:24 +00:00
|
|
|
[⊢ (match- e- [p- s-] ...
|
2018-07-30 21:36:42 +00:00
|
|
|
[_ (error "incomplete pattern match")])
|
|
|
|
(⇒ : (U τ-s ...))
|
2018-08-08 19:20:09 +00:00
|
|
|
(⇒ ep (eps ... ...))
|
2018-07-30 21:36:42 +00:00
|
|
|
(⇒ f (fs ... ...))
|
|
|
|
(⇒ s (ss ... ...))])
|
|
|
|
|
2018-07-25 21:26:47 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Utilities
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
(define-typed-syntax (print-type e) ≫
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ) (⇒ ep (~effs eps ...)) (⇒ f (~effs fs ...)) (⇒ s (~effs ss ...))]
|
2018-07-25 21:26:47 +00:00
|
|
|
#:do [(displayln (type->str #'τ))]
|
|
|
|
----------------------------------
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ e- (⇒ : τ) (⇒ ep (eps ...)) (⇒ f (fs ...)) (⇒ s (ss ...))])
|
2018-07-25 21:26:47 +00:00
|
|
|
|
|
|
|
(define-typed-syntax (print-role e) ≫
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ e ≫ e- (⇒ : τ) (⇒ ep (~effs eps ...)) (⇒ f (~effs fs ...)) (⇒ s (~effs ss ...))]
|
|
|
|
#:do [(for ([r (in-syntax #'(fs ...))])
|
2018-07-25 21:26:47 +00:00
|
|
|
(displayln (type->str r)))]
|
|
|
|
----------------------------------
|
2018-08-08 19:20:09 +00:00
|
|
|
[⊢ e- (⇒ : τ) (⇒ ep (eps ...)) (⇒ f (fs ...)) (⇒ s (ss ...))])
|
2018-07-27 21:16:44 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Tests
|
2018-09-12 19:06:08 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
2018-09-12 21:03:19 +00:00
|
|
|
(module+ test
|
|
|
|
(check-type (spawn (U (Message (Tuple String Int))
|
|
|
|
(Observe (Tuple String ★/t)))
|
|
|
|
(start-facet echo
|
|
|
|
(on (message (tuple "ping" (bind x Int)))
|
|
|
|
(send! (tuple "pong" x)))))
|
|
|
|
: ★/t)
|
|
|
|
(typecheck-fail (spawn (U (Message (Tuple String Int))
|
|
|
|
(Message (Tuple String String))
|
|
|
|
(Observe (Tuple String ★/t)))
|
|
|
|
(start-facet echo
|
|
|
|
(on (message (tuple "ping" (bind x Int)))
|
|
|
|
(send! (tuple "pong" x)))))))
|
|
|
|
|
2018-09-12 19:06:08 +00:00
|
|
|
;; local definitions
|
|
|
|
#;(module+ test
|
|
|
|
;; these cause an error in rackunit-typechecking, don't know why :/
|
|
|
|
#;(check-type (let ()
|
|
|
|
(begin
|
|
|
|
(define id : Int 1234)
|
|
|
|
id))
|
|
|
|
: Int
|
|
|
|
-> 1234)
|
|
|
|
#;(check-type (let ()
|
|
|
|
(define (spawn-cell [initial-value : Int])
|
|
|
|
(define id 1234)
|
|
|
|
id)
|
|
|
|
(typed-app spawn-cell 42))
|
|
|
|
: Int
|
|
|
|
-> 1234)
|
|
|
|
(check-equal? (let ()
|
|
|
|
(define id : Int 1234)
|
|
|
|
id)
|
|
|
|
1234)
|
|
|
|
#;(check-equal? (let ()
|
|
|
|
(define (spawn-cell [initial-value : Int])
|
|
|
|
(define id 1234)
|
|
|
|
id)
|
|
|
|
(typed-app spawn-cell 42))
|
|
|
|
1234))
|