try syntax-local-lift-module-end for lift+define-role
This commit is contained in:
parent
25860019c6
commit
1805b936be
|
@ -32,13 +32,11 @@
|
||||||
(Role (client)
|
(Role (client)
|
||||||
(Reacts (Asserted Account))))
|
(Reacts (Asserted Account))))
|
||||||
|
|
||||||
(check-simulates client-role client-role)
|
|
||||||
(check-simulates client-role account-manager-role)
|
|
||||||
|
|
||||||
(run-ground-dataspace ds-type
|
(run-ground-dataspace ds-type
|
||||||
|
|
||||||
(spawn ds-type
|
(spawn ds-type
|
||||||
(export-roles "account-manager-role.rktd"
|
(lift+define-role acct-mngr-role
|
||||||
(start-facet account-manager
|
(start-facet account-manager
|
||||||
(field [balance Int 0])
|
(field [balance Int 0])
|
||||||
(assert (account (ref balance)))
|
(assert (account (ref balance)))
|
||||||
|
@ -46,15 +44,22 @@
|
||||||
(set! balance (+ (ref balance) amount))))))
|
(set! balance (+ (ref balance) amount))))))
|
||||||
|
|
||||||
(spawn ds-type
|
(spawn ds-type
|
||||||
(print-role
|
(lift+define-role obs-role
|
||||||
(start-facet observer
|
(start-facet observer
|
||||||
(on (asserted (account (bind amount Int)))
|
(on (asserted (account (bind amount Int)))
|
||||||
(displayln amount)))))
|
(displayln amount)))))
|
||||||
|
|
||||||
(spawn ds-type
|
(spawn ds-type
|
||||||
(print-role
|
(lift+define-role buyer-role
|
||||||
(start-facet buyer
|
(start-facet buyer
|
||||||
(on (asserted (observe (deposit discard)))
|
(on (asserted (observe (deposit discard)))
|
||||||
(start-facet deposits
|
(start-facet deposits
|
||||||
(assert (deposit 100))
|
(assert (deposit 100))
|
||||||
(assert (deposit -30))))))))
|
(assert (deposit -30))))))))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-simulates acct-mngr-role account-manager-role)
|
||||||
|
(check-simulates obs-role client-role)
|
||||||
|
;; Tried to write this, then it failed, I looked and buyer doesn't actually implement that spec
|
||||||
|
#;(check-simulates buyer-role client-role)
|
||||||
|
)
|
||||||
|
|
|
@ -4,6 +4,7 @@
|
||||||
#%app
|
#%app
|
||||||
(rename-out [typed-quote quote])
|
(rename-out [typed-quote quote])
|
||||||
#%top-interaction
|
#%top-interaction
|
||||||
|
module+ module*
|
||||||
;; require & provides
|
;; require & provides
|
||||||
require only-in prefix-in except-in rename-in
|
require only-in prefix-in except-in rename-in
|
||||||
provide all-defined-out all-from-out rename-out except-out
|
provide all-defined-out all-from-out rename-out except-out
|
||||||
|
@ -63,7 +64,7 @@
|
||||||
;; DEBUG and utilities
|
;; DEBUG and utilities
|
||||||
print-type print-role role-strings
|
print-type print-role role-strings
|
||||||
;; Behavioral Roles
|
;; Behavioral Roles
|
||||||
export-roles check-simulates
|
export-roles check-simulates lift+define-role
|
||||||
;; Extensions
|
;; Extensions
|
||||||
match cond
|
match cond
|
||||||
submod for-syntax for-meta only-in except-in
|
submod for-syntax for-meta only-in except-in
|
||||||
|
@ -659,12 +660,17 @@
|
||||||
(define (synd->proto ty)
|
(define (synd->proto ty)
|
||||||
(let convert ([ty (resugar-type ty)])
|
(let convert ([ty (resugar-type ty)])
|
||||||
(syntax-parse ty
|
(syntax-parse ty
|
||||||
#:literals (★/t Discard ∀/internal →/internal Role/internal Stop Reacts)
|
#:literals (★/t Bind Discard ∀/internal →/internal Role/internal Stop Reacts)
|
||||||
[(ctor:id t ...)
|
[(ctor:id t ...)
|
||||||
#:when (dict-has-key? TRANSLATION# #'ctor)
|
#:when (dict-has-key? TRANSLATION# #'ctor)
|
||||||
(apply (dict-ref TRANSLATION# #'ctor) (stx-map convert #'(t ...)))]
|
(apply (dict-ref TRANSLATION# #'ctor) (stx-map convert #'(t ...)))]
|
||||||
[★/t proto:⋆]
|
[★/t proto:⋆]
|
||||||
[Discard proto:⋆] ;; TODO - should prob have a Discard type in proto
|
[(Bind t)
|
||||||
|
;; TODO - this is debatable handling
|
||||||
|
(convert #'t)]
|
||||||
|
[Discard
|
||||||
|
;; TODO - should prob have a Discard type in proto
|
||||||
|
proto:⋆]
|
||||||
[(∀/internal (X ...) body)
|
[(∀/internal (X ...) body)
|
||||||
;; TODO
|
;; TODO
|
||||||
(error "unimplemented")]
|
(error "unimplemented")]
|
||||||
|
@ -698,6 +704,15 @@
|
||||||
----------------------------------------
|
----------------------------------------
|
||||||
[⊢ e- (⇒ : τ) (⇒ ν-ep (eps ...)) (⇒ ν-f (fs ...)) (⇒ ν-s (ss ...))])
|
[⊢ e- (⇒ : τ) (⇒ ν-ep (eps ...)) (⇒ ν-f (fs ...)) (⇒ ν-s (ss ...))])
|
||||||
|
|
||||||
|
(define-typed-syntax (lift+define-role x:id e:expr) ≫
|
||||||
|
[⊢ e ≫ e- (⇒ : τ) (⇒ ν-ep (~effs)) (⇒ ν-f ((~and r (~Role (_) _ ...)))) (⇒ ν-s (~effs))]
|
||||||
|
;; because turnstile introduces a lot of intdef scopes; ideally, we'd be able to synthesize somethign
|
||||||
|
;; with the right module scopes
|
||||||
|
#:with x+ (syntax-local-introduce (datum->syntax #f (syntax-e #'x)))
|
||||||
|
#:do [(syntax-local-lift-module-end-declaration #`(define-type-alias x+ r))]
|
||||||
|
----------------------------------------
|
||||||
|
[⊢ e- (⇒ : τ) (⇒ ν-ep ()) (⇒ ν-f (r)) (⇒ ν-s ())])
|
||||||
|
|
||||||
(define-syntax-parser check-simulates
|
(define-syntax-parser check-simulates
|
||||||
[(_ τ-impl:type τ-spec:type)
|
[(_ τ-impl:type τ-spec:type)
|
||||||
(define τ-impl- (synd->proto #'τ-impl.norm))
|
(define τ-impl- (synd->proto #'τ-impl.norm))
|
||||||
|
@ -708,6 +723,7 @@
|
||||||
(raise-syntax-error #f "type doesn't simulate spec" this-syntax))
|
(raise-syntax-error #f "type doesn't simulate spec" this-syntax))
|
||||||
#'(#%app- void-)])
|
#'(#%app- void-)])
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Tests
|
;; Tests
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
Loading…
Reference in New Issue