roles for bank account facets
This commit is contained in:
parent
29e09ff3ef
commit
71c2846a93
|
@ -27,7 +27,18 @@
|
||||||
(set! balance (+ (ref balance) amount))))))
|
(set! balance (+ (ref balance) amount))))))
|
||||||
|
|
||||||
(spawn ds-type
|
(spawn ds-type
|
||||||
|
(print-role
|
||||||
(start-facet observer
|
(start-facet observer
|
||||||
(fields)
|
(fields)
|
||||||
(on (asserted (account (bind amount Int)))
|
(on (asserted (account (bind amount Int)))
|
||||||
(displayln amount))))
|
(displayln amount)))))
|
||||||
|
|
||||||
|
(spawn ds-type
|
||||||
|
(print-role
|
||||||
|
(start-facet buyer
|
||||||
|
(fields)
|
||||||
|
(on (asserted (observe (deposit discard)))
|
||||||
|
(start-facet deposits
|
||||||
|
(fields)
|
||||||
|
(assert (deposit 100))
|
||||||
|
(assert (deposit -30)))))))
|
|
@ -102,6 +102,22 @@
|
||||||
(stx-car #'tys-)
|
(stx-car #'tys-)
|
||||||
(syntax/loc stx (U* . tys-)))]))
|
(syntax/loc stx (U* . tys-)))]))
|
||||||
|
|
||||||
|
;; for looking at the "effects"
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-syntax ~effs
|
||||||
|
(pattern-expander
|
||||||
|
(syntax-parser
|
||||||
|
[(_ eff:id ...)
|
||||||
|
#:with tmp (generate-temporary 'effss)
|
||||||
|
#'(~and tmp
|
||||||
|
(~parse (eff ...) (stx-or #'tmp #'())))])))
|
||||||
|
|
||||||
|
(define (stx-truth? a)
|
||||||
|
(and a (not (and (syntax? a) (false? (syntax-e a))))))
|
||||||
|
(define (stx-or a b)
|
||||||
|
(cond [(stx-truth? a) a]
|
||||||
|
[else b])))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; User Defined Types, aka Constructors
|
;; User Defined Types, aka Constructors
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -430,11 +446,11 @@
|
||||||
[⊢ p ≫ _ (⇒ : τp)]
|
[⊢ p ≫ _ (⇒ : τp)]
|
||||||
#:with p- (compile-syndicate-pattern #'p)
|
#:with p- (compile-syndicate-pattern #'p)
|
||||||
#:with ([x:id τ:type] ...) (pat-bindings #'p)
|
#:with ([x:id τ:type] ...) (pat-bindings #'p)
|
||||||
[[x ≫ x- : τ a (U*) r (U*) e (U*)] ... ⊢ s ≫ s- (⇒ a τ-as) (⇒ r τ-rs) (⇒ e (τ-e ...))]
|
[[x ≫ x- : τ] ... ⊢ s ≫ s- (⇒ a (~effs τ-as ...))
|
||||||
#:do [(displayln (stx-map type->str #'τ-as))]
|
(⇒ r (~effs τ-rs ...))
|
||||||
#:do [(displayln (stx-andmap bot? #'τ-as))]
|
(⇒ e (~effs τ-e ...))]
|
||||||
;; #:do [(displayln (stx-andmap bot? #'τ-rs))]
|
#:fail-unless (and (stx-andmap bot? #'(τ-as ...)) (stx-andmap bot? #'(τ-rs ...)))
|
||||||
#:fail-unless (and (stx-andmap bot? #'τ-as) (stx-andmap bot? #'τ-rs)) "illegal context"
|
"illegal context"
|
||||||
#:with (rhs ...) (if (stx-null? #'(τ-e ...)) #'((U*)) #'(τ-e ...))
|
#:with (rhs ...) (if (stx-null? #'(τ-e ...)) #'((U*)) #'(τ-e ...))
|
||||||
#:with τ-r #'(Reaction (a/r.react-con τp) rhs ...)
|
#:with τ-r #'(Reaction (a/r.react-con τp) rhs ...)
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
|
|
Loading…
Reference in New Issue