Hide legacy typed/syndicate #lang, consolidate to the "roles" version
This commit is contained in:
parent
8b67d0ba03
commit
c3559f1611
|
@ -1,14 +1,19 @@
|
||||||
#lang typed/syndicate
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
;; Expected Output
|
||||||
|
;; 0
|
||||||
|
;; 70
|
||||||
|
;; #f
|
||||||
|
|
||||||
(define-constructor (account balance)
|
(define-constructor (account balance)
|
||||||
#:type-constructor AccountT
|
#:type-constructor AccountT
|
||||||
#:with Account (AccountT Int)
|
#:with Account (AccountT Int)
|
||||||
#:with AccountRequest (AccountT ★))
|
#:with AccountRequest (AccountT ★/t))
|
||||||
|
|
||||||
(define-constructor (deposit amount)
|
(define-constructor (deposit amount)
|
||||||
#:type-constructor DepositT
|
#:type-constructor DepositT
|
||||||
#:with Deposit (DepositT Int)
|
#:with Deposit (DepositT Int)
|
||||||
#:with DepositRequest (DepositT ★))
|
#:with DepositRequest (DepositT ★/t))
|
||||||
|
|
||||||
(define-type-alias ds-type
|
(define-type-alias ds-type
|
||||||
(U Account
|
(U Account
|
||||||
|
@ -18,45 +23,43 @@
|
||||||
(Observe DepositRequest)
|
(Observe DepositRequest)
|
||||||
(Observe (Observe DepositRequest))))
|
(Observe (Observe DepositRequest))))
|
||||||
|
|
||||||
(dataspace ds-type
|
(define-type-alias account-manager-role
|
||||||
|
(Role (account-manager)
|
||||||
|
(Shares Account)
|
||||||
|
(Reacts (Asserted Deposit))))
|
||||||
|
|
||||||
(spawn ds-type
|
(define-type-alias client-role
|
||||||
(facet _
|
(Role (client)
|
||||||
(fields [balance Int 0])
|
(Reacts (Asserted Account))))
|
||||||
(assert (account (ref balance)))
|
|
||||||
(on (asserted (deposit (bind amount Int)))
|
|
||||||
(set! balance (+ (ref balance) amount)))))
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(facet _
|
|
||||||
(fields)
|
|
||||||
(on (asserted (account (bind amount Int)))
|
|
||||||
(displayln amount))))
|
|
||||||
|
|
||||||
(spawn ds-type
|
(run-ground-dataspace ds-type
|
||||||
(facet _
|
|
||||||
(fields)
|
|
||||||
(on (asserted (observe (deposit discard)))
|
|
||||||
(facet _
|
|
||||||
(fields)
|
|
||||||
(assert (deposit 100))
|
|
||||||
(assert (deposit -30)))))))
|
|
||||||
|
|
||||||
#|
|
(spawn ds-type
|
||||||
;; Hello-worldish "bank account" example.
|
(lift+define-role acct-mngr-role
|
||||||
|
(start-facet account-manager
|
||||||
|
(field [balance Int 0])
|
||||||
|
(assert (account (ref balance)))
|
||||||
|
(on (asserted (deposit (bind amount Int)))
|
||||||
|
(set! balance (+ (ref balance) amount))))))
|
||||||
|
|
||||||
(struct account (balance) #:prefab)
|
(spawn ds-type
|
||||||
(struct deposit (amount) #:prefab)
|
(lift+define-role obs-role
|
||||||
|
(start-facet observer
|
||||||
|
(on (asserted (account (bind amount Int)))
|
||||||
|
(displayln amount)))))
|
||||||
|
|
||||||
(spawn (field [balance 0])
|
(spawn ds-type
|
||||||
(assert (account (balance)))
|
(lift+define-role buyer-role
|
||||||
(on (message (deposit $amount))
|
(start-facet buyer
|
||||||
(balance (+ (balance) amount))))
|
(on (asserted (observe (deposit discard)))
|
||||||
|
(start-facet deposits
|
||||||
|
(assert (deposit 100))
|
||||||
|
(assert (deposit -30))))))))
|
||||||
|
|
||||||
(spawn (on (asserted (account $balance))
|
(module+ test
|
||||||
(printf "Balance changed to ~a\n" balance)))
|
(check-simulates acct-mngr-role account-manager-role)
|
||||||
|
(check-simulates obs-role client-role)
|
||||||
(spawn* (until (asserted (observe (deposit _))))
|
;; Tried to write this, then it failed, I looked and buyer doesn't actually implement that spec
|
||||||
(send! (deposit +100))
|
#;(check-simulates buyer-role client-role)
|
||||||
(send! (deposit -30)))
|
)
|
||||||
|#
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output
|
;; Expected Output
|
||||||
;; leader learns that there are 5 copies of The Wind in the Willows
|
;; leader learns that there are 5 copies of The Wind in the Willows
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; adapted from section 8.3 of Tony's dissertation
|
;; adapted from section 8.3 of Tony's dissertation
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require typed/syndicate/drivers/tcp)
|
(require typed/syndicate/drivers/tcp)
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(define-constructor (file name content)
|
(define-constructor (file name content)
|
||||||
#:type-constructor FileT
|
#:type-constructor FileT
|
||||||
|
@ -31,4 +31,4 @@
|
||||||
(define-type-alias Writer
|
(define-type-alias Writer
|
||||||
(Role (writer)
|
(Role (writer)
|
||||||
(Sends Save)
|
(Sends Save)
|
||||||
(Sends Delete)))
|
(Sends Delete)))
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; Protocol
|
;; Protocol
|
||||||
|
@ -550,8 +550,8 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(spawn-client (string->job INPUT)))
|
(spawn-client (string->job INPUT)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(verify-actors (Eventually (A (JobCompletion ID (List InputTask) TaskResult)))
|
#;(verify-actors #;(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))
|
||||||
#;(Always (Implies (A (Observe (JobCompletion ID (List InputTask) ★/t)))
|
(Always (Implies (A (Observe (JobCompletion ID (List InputTask) ★/t)))
|
||||||
(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))))
|
(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))))
|
||||||
job-manager-impl
|
job-manager-impl
|
||||||
task-manager-impl
|
task-manager-impl
|
||||||
|
@ -570,3 +570,7 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(check-has-simulating-subgraph task-manager-impl TaskPerformer)
|
(check-has-simulating-subgraph task-manager-impl TaskPerformer)
|
||||||
(check-has-simulating-subgraph task-manager-impl TaskAssigner)
|
(check-has-simulating-subgraph task-manager-impl TaskAssigner)
|
||||||
(check-has-simulating-subgraph job-manager-impl TaskAssigner))
|
(check-has-simulating-subgraph job-manager-impl TaskAssigner))
|
||||||
|
|
||||||
|
;; infinite loop?
|
||||||
|
#;(module+ test
|
||||||
|
(check-simulates job-manager-impl job-manager-impl))
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output:
|
;; Expected Output:
|
||||||
#|
|
#|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output
|
;; Expected Output
|
||||||
;; pong: 8339
|
;; pong: 8339
|
|
@ -1,8 +1,8 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(provide a-fun)
|
(provide a-fun)
|
||||||
|
|
||||||
(define (a-fun [x : Int] -> Int)
|
(define (a-fun [x : Int] -> Int)
|
||||||
(+ x 1))
|
(+ x 1))
|
||||||
|
|
||||||
#;(a-fun 5)
|
#;(a-fun 5)
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output:
|
;; Expected Output:
|
||||||
#|
|
#|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require-struct msg #:as Msg
|
(require-struct msg #:as Msg
|
||||||
#:from "driver.rkt")
|
#:from "driver.rkt")
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require/typed "lib.rkt" [x : Int])
|
||||||
|
|
||||||
|
(displayln (+ x 1))
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require "provides.rkt")
|
||||||
|
|
||||||
|
(a-fun 5)
|
|
@ -1,65 +0,0 @@
|
||||||
#lang typed/syndicate/roles
|
|
||||||
|
|
||||||
;; Expected Output
|
|
||||||
;; 0
|
|
||||||
;; 70
|
|
||||||
;; #f
|
|
||||||
|
|
||||||
(define-constructor (account balance)
|
|
||||||
#:type-constructor AccountT
|
|
||||||
#:with Account (AccountT Int)
|
|
||||||
#:with AccountRequest (AccountT ★/t))
|
|
||||||
|
|
||||||
(define-constructor (deposit amount)
|
|
||||||
#:type-constructor DepositT
|
|
||||||
#:with Deposit (DepositT Int)
|
|
||||||
#:with DepositRequest (DepositT ★/t))
|
|
||||||
|
|
||||||
(define-type-alias ds-type
|
|
||||||
(U Account
|
|
||||||
(Observe AccountRequest)
|
|
||||||
(Observe (Observe AccountRequest))
|
|
||||||
Deposit
|
|
||||||
(Observe DepositRequest)
|
|
||||||
(Observe (Observe DepositRequest))))
|
|
||||||
|
|
||||||
(define-type-alias account-manager-role
|
|
||||||
(Role (account-manager)
|
|
||||||
(Shares Account)
|
|
||||||
(Reacts (Asserted Deposit))))
|
|
||||||
|
|
||||||
(define-type-alias client-role
|
|
||||||
(Role (client)
|
|
||||||
(Reacts (Asserted Account))))
|
|
||||||
|
|
||||||
|
|
||||||
(run-ground-dataspace ds-type
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(lift+define-role acct-mngr-role
|
|
||||||
(start-facet account-manager
|
|
||||||
(field [balance Int 0])
|
|
||||||
(assert (account (ref balance)))
|
|
||||||
(on (asserted (deposit (bind amount Int)))
|
|
||||||
(set! balance (+ (ref balance) amount))))))
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(lift+define-role obs-role
|
|
||||||
(start-facet observer
|
|
||||||
(on (asserted (account (bind amount Int)))
|
|
||||||
(displayln amount)))))
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(lift+define-role buyer-role
|
|
||||||
(start-facet buyer
|
|
||||||
(on (asserted (observe (deposit discard)))
|
|
||||||
(start-facet deposits
|
|
||||||
(assert (deposit 100))
|
|
||||||
(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)
|
|
||||||
)
|
|
|
@ -1,5 +0,0 @@
|
||||||
#lang typed/syndicate/roles
|
|
||||||
|
|
||||||
(require/typed "lib.rkt" [x : Int])
|
|
||||||
|
|
||||||
(displayln (+ x 1))
|
|
|
@ -1,5 +0,0 @@
|
||||||
#lang typed/syndicate/roles
|
|
||||||
|
|
||||||
(require "provides.rkt")
|
|
||||||
|
|
||||||
(a-fun 5)
|
|
|
@ -1,163 +0,0 @@
|
||||||
#lang typed/syndicate/roles
|
|
||||||
|
|
||||||
;; Expected Output
|
|
||||||
;; Completed Order:
|
|
||||||
;; Catch 22
|
|
||||||
;; 10001483
|
|
||||||
;; March 9th
|
|
||||||
|
|
||||||
(define-constructor (price v)
|
|
||||||
#:type-constructor PriceT
|
|
||||||
#:with Price (PriceT Int))
|
|
||||||
|
|
||||||
(define-constructor (out-of-stock)
|
|
||||||
#:type-constructor OutOfStockT
|
|
||||||
#:with OutOfStock (OutOfStockT))
|
|
||||||
|
|
||||||
(define-type-alias QuoteAnswer
|
|
||||||
(U Price OutOfStock))
|
|
||||||
|
|
||||||
(define-constructor (quote title answer)
|
|
||||||
#:type-constructor QuoteT
|
|
||||||
#:with Quote (QuoteT String QuoteAnswer)
|
|
||||||
#:with QuoteRequest (Observe (QuoteT String ★/t))
|
|
||||||
#:with QuoteInterest (Observe (QuoteT ★/t ★/t)))
|
|
||||||
|
|
||||||
(define-constructor (split-proposal title price contribution accepted)
|
|
||||||
#:type-constructor SplitProposalT
|
|
||||||
#:with SplitProposal (SplitProposalT String Int Int Bool)
|
|
||||||
#:with SplitRequest (Observe (SplitProposalT String Int Int ★/t))
|
|
||||||
#:with SplitInterest (Observe (SplitProposalT ★/t ★/t ★/t ★/t)))
|
|
||||||
|
|
||||||
(define-constructor (order-id id)
|
|
||||||
#:type-constructor OrderIdT
|
|
||||||
#:with OrderId (OrderIdT Int))
|
|
||||||
|
|
||||||
(define-constructor (delivery-date date)
|
|
||||||
#:type-constructor DeliveryDateT
|
|
||||||
#:with DeliveryDate (DeliveryDateT String))
|
|
||||||
|
|
||||||
(define-type-alias (Maybe t)
|
|
||||||
(U t Bool))
|
|
||||||
|
|
||||||
(define-constructor (order title price oid delivery-date)
|
|
||||||
#:type-constructor OrderT
|
|
||||||
#:with Order (OrderT String Int (Maybe OrderId) (Maybe DeliveryDate))
|
|
||||||
#:with OrderRequest (Observe (OrderT String Int ★/t ★/t))
|
|
||||||
#:with OrderInterest (Observe (OrderT ★/t ★/t ★/t ★/t)))
|
|
||||||
|
|
||||||
(define-type-alias ds-type
|
|
||||||
(U ;; quotes
|
|
||||||
Quote
|
|
||||||
QuoteRequest
|
|
||||||
(Observe QuoteInterest)
|
|
||||||
;; splits
|
|
||||||
SplitProposal
|
|
||||||
SplitRequest
|
|
||||||
(Observe SplitInterest)
|
|
||||||
;; orders
|
|
||||||
Order
|
|
||||||
OrderRequest
|
|
||||||
(Observe OrderInterest)))
|
|
||||||
|
|
||||||
(define-type-alias seller-role
|
|
||||||
(Role (seller)
|
|
||||||
(During (Observe (QuoteT String ★/t))
|
|
||||||
(Shares (QuoteT String QuoteAnswer)))
|
|
||||||
#;(Reacts (Asserted (Observe (QuoteT String ★/t)))
|
|
||||||
(Role (_)
|
|
||||||
;; QuoteAnswer was originally, erroneously, Int
|
|
||||||
(Shares (QuoteT String QuoteAnswer))))))
|
|
||||||
|
|
||||||
(run-ground-dataspace ds-type
|
|
||||||
|
|
||||||
;; seller
|
|
||||||
(spawn ds-type
|
|
||||||
(lift+define-role seller-impl
|
|
||||||
(start-facet _ ;; #:implements seller-role
|
|
||||||
(field [book (Tuple String Int) (tuple "Catch 22" 22)]
|
|
||||||
[next-order-id Int 10001483])
|
|
||||||
(on (asserted (observe (quote (bind title String) discard)))
|
|
||||||
(start-facet x
|
|
||||||
(on (retracted (observe (quote title discard)))
|
|
||||||
(stop x))
|
|
||||||
(define answer
|
|
||||||
(match title
|
|
||||||
["Catch 22"
|
|
||||||
(price 22)]
|
|
||||||
[_
|
|
||||||
(out-of-stock)]))
|
|
||||||
(assert (quote title answer))))
|
|
||||||
(on (asserted (observe (order (bind title String) (bind offer Int) discard discard)))
|
|
||||||
(start-facet x
|
|
||||||
(on (retracted (observe (order title offer discard discard)))
|
|
||||||
(stop x))
|
|
||||||
(let ([asking-price 22])
|
|
||||||
(if (and (equal? title "Catch 22") (>= offer asking-price))
|
|
||||||
(let ([id (ref next-order-id)])
|
|
||||||
(set! next-order-id (+ 1 id))
|
|
||||||
(assert (order title offer (order-id id) (delivery-date "March 9th"))))
|
|
||||||
(assert (order title offer #f #f)))))))))
|
|
||||||
|
|
||||||
;; buyer A
|
|
||||||
(spawn ds-type
|
|
||||||
(lift+define-role buyer-a-impl
|
|
||||||
(start-facet buyer
|
|
||||||
(field [title String "Catch 22"]
|
|
||||||
[budget Int 1000])
|
|
||||||
(on (asserted (quote (ref title) (bind answer QuoteAnswer)))
|
|
||||||
(match answer
|
|
||||||
[(out-of-stock)
|
|
||||||
(stop buyer)]
|
|
||||||
[(price (bind amount Int))
|
|
||||||
(start-facet negotiation
|
|
||||||
(field [contribution Int (/ amount 2)])
|
|
||||||
(on (asserted (split-proposal (ref title) amount (ref contribution) (bind accept? Bool)))
|
|
||||||
(if accept?
|
|
||||||
(stop buyer)
|
|
||||||
(if (> (ref contribution) (- amount 5))
|
|
||||||
(stop negotiation (displayln "negotiation failed"))
|
|
||||||
(set! contribution
|
|
||||||
(+ (ref contribution) (/ (- amount (ref contribution)) 2)))))))])))))
|
|
||||||
|
|
||||||
;; buyer B
|
|
||||||
(spawn ds-type
|
|
||||||
(lift+define-role buyer-b-impl
|
|
||||||
(start-facet buyer-b
|
|
||||||
(field [funds Int 5])
|
|
||||||
(on (asserted (observe (split-proposal (bind title String) (bind price Int) (bind their-contribution Int) discard)))
|
|
||||||
(let ([my-contribution (- price their-contribution)])
|
|
||||||
(cond
|
|
||||||
[(> my-contribution (ref funds))
|
|
||||||
(start-facet decline
|
|
||||||
(assert (split-proposal title price their-contribution #f))
|
|
||||||
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
|
||||||
(stop decline)))]
|
|
||||||
[#t
|
|
||||||
(start-facet accept
|
|
||||||
(assert (split-proposal title price their-contribution #t))
|
|
||||||
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
|
||||||
(stop accept))
|
|
||||||
(on start
|
|
||||||
(spawn ds-type
|
|
||||||
(start-facet purchase
|
|
||||||
(on (asserted (order title price (bind order-id? (Maybe OrderId)) (bind delivery-date? (Maybe DeliveryDate))))
|
|
||||||
(match (tuple order-id? delivery-date?)
|
|
||||||
[(tuple (order-id (bind id Int)) (delivery-date (bind date String)))
|
|
||||||
;; complete!
|
|
||||||
(begin (displayln "Completed Order:")
|
|
||||||
(displayln title)
|
|
||||||
(displayln id)
|
|
||||||
(displayln date)
|
|
||||||
(stop purchase))]
|
|
||||||
[discard
|
|
||||||
(begin (displayln "Order Rejected")
|
|
||||||
(stop purchase))]))))))]))))))
|
|
||||||
)
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(check-simulates seller-impl seller-impl)
|
|
||||||
;; found a bug in spec, see seller-role above
|
|
||||||
(check-simulates seller-impl seller-role)
|
|
||||||
(check-simulates buyer-a-impl buyer-a-impl)
|
|
||||||
(check-simulates buyer-b-impl buyer-b-impl))
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output
|
;; Expected Output
|
||||||
;; f: 0
|
;; f: 0
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(run-ground-dataspace Int
|
(run-ground-dataspace Int
|
||||||
(spawn Int
|
(spawn Int
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output
|
;; Expected Output
|
||||||
;; +GO
|
;; +GO
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output
|
;; Expected Output
|
||||||
;; adding key2 -> 88
|
;; adding key2 -> 88
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output
|
;; Expected Output
|
||||||
;; size: 0
|
;; size: 0
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output
|
;; Expected Output
|
||||||
;; query: 0
|
;; query: 0
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output:
|
;; Expected Output:
|
||||||
;; +42
|
;; +42
|
|
@ -20,14 +20,14 @@
|
||||||
(define-constructor (quote title answer)
|
(define-constructor (quote title answer)
|
||||||
#:type-constructor QuoteT
|
#:type-constructor QuoteT
|
||||||
#:with Quote (QuoteT String QuoteAnswer)
|
#:with Quote (QuoteT String QuoteAnswer)
|
||||||
#:with QuoteRequest (Observe (QuoteT String ★))
|
#:with QuoteRequest (Observe (QuoteT String ★/t))
|
||||||
#:with QuoteInterest (Observe (QuoteT ★ ★)))
|
#:with QuoteInterest (Observe (QuoteT ★/t ★/t)))
|
||||||
|
|
||||||
(define-constructor (split-proposal title price contribution accepted)
|
(define-constructor (split-proposal title price contribution accepted)
|
||||||
#:type-constructor SplitProposalT
|
#:type-constructor SplitProposalT
|
||||||
#:with SplitProposal (SplitProposalT String Int Int Bool)
|
#:with SplitProposal (SplitProposalT String Int Int Bool)
|
||||||
#:with SplitRequest (Observe (SplitProposalT String Int Int ★))
|
#:with SplitRequest (Observe (SplitProposalT String Int Int ★/t))
|
||||||
#:with SplitInterest (Observe (SplitProposalT ★ ★ ★ ★)))
|
#:with SplitInterest (Observe (SplitProposalT ★/t ★/t ★/t ★/t)))
|
||||||
|
|
||||||
(define-constructor (order-id id)
|
(define-constructor (order-id id)
|
||||||
#:type-constructor OrderIdT
|
#:type-constructor OrderIdT
|
||||||
|
@ -40,11 +40,11 @@
|
||||||
(define-type-alias (Maybe t)
|
(define-type-alias (Maybe t)
|
||||||
(U t Bool))
|
(U t Bool))
|
||||||
|
|
||||||
(define-constructor (order title price id delivery-date)
|
(define-constructor (order title price oid delivery-date)
|
||||||
#:type-constructor OrderT
|
#:type-constructor OrderT
|
||||||
#:with Order (OrderT String Int (Maybe OrderId) (Maybe DeliveryDate))
|
#:with Order (OrderT String Int (Maybe OrderId) (Maybe DeliveryDate))
|
||||||
#:with OrderRequest (Observe (OrderT String Int ★ ★))
|
#:with OrderRequest (Observe (OrderT String Int ★/t ★/t))
|
||||||
#:with OrderInterest (Observe (OrderT ★ ★ ★ ★)))
|
#:with OrderInterest (Observe (OrderT ★/t ★/t ★/t ★/t)))
|
||||||
|
|
||||||
(define-type-alias ds-type
|
(define-type-alias ds-type
|
||||||
(U ;; quotes
|
(U ;; quotes
|
||||||
|
@ -60,88 +60,104 @@
|
||||||
OrderRequest
|
OrderRequest
|
||||||
(Observe OrderInterest)))
|
(Observe OrderInterest)))
|
||||||
|
|
||||||
(dataspace ds-type
|
(define-type-alias seller-role
|
||||||
|
(Role (seller)
|
||||||
|
(During (Observe (QuoteT String ★/t))
|
||||||
|
(Shares (QuoteT String QuoteAnswer)))
|
||||||
|
#;(Reacts (Asserted (Observe (QuoteT String ★/t)))
|
||||||
|
(Role (_)
|
||||||
|
;; QuoteAnswer was originally, erroneously, Int
|
||||||
|
(Shares (QuoteT String QuoteAnswer))))))
|
||||||
|
|
||||||
|
(run-ground-dataspace ds-type
|
||||||
|
|
||||||
;; seller
|
;; seller
|
||||||
(spawn ds-type
|
(spawn ds-type
|
||||||
(facet _
|
(lift+define-role seller-impl
|
||||||
(fields [book (Tuple String Int) (tuple "Catch 22" 22)]
|
(start-facet _ ;; #:implements seller-role
|
||||||
[next-order-id Int 10001483])
|
(field [book (Tuple String Int) (tuple "Catch 22" 22)]
|
||||||
(on (asserted (observe (quote (bind title String) discard)))
|
[next-order-id Int 10001483])
|
||||||
(facet x
|
(on (asserted (observe (quote (bind title String) discard)))
|
||||||
(fields)
|
(start-facet x
|
||||||
(on (retracted (observe (quote title discard)))
|
(on (retracted (observe (quote title discard)))
|
||||||
(stop x (begin)))
|
(stop x))
|
||||||
(match title
|
(define answer
|
||||||
["Catch 22"
|
(match title
|
||||||
(assert (quote title (price 22)))]
|
["Catch 22"
|
||||||
[discard
|
(price 22)]
|
||||||
(assert (quote title (out-of-stock)))])))
|
[_
|
||||||
(on (asserted (observe (order (bind title String) (bind offer Int) discard discard)))
|
(out-of-stock)]))
|
||||||
(facet x
|
(assert (quote title answer))))
|
||||||
(fields)
|
(on (asserted (observe (order (bind title String) (bind offer Int) discard discard)))
|
||||||
(on (retracted (observe (order title offer discard discard)))
|
(start-facet x
|
||||||
(stop x (begin)))
|
(on (retracted (observe (order title offer discard discard)))
|
||||||
(let [asking-price 22]
|
(stop x))
|
||||||
(if (and (equal? title "Catch 22") (>= offer asking-price))
|
(let ([asking-price 22])
|
||||||
(let [id (ref next-order-id)]
|
(if (and (equal? title "Catch 22") (>= offer asking-price))
|
||||||
(begin (set! next-order-id (+ 1 id))
|
(let ([id (ref next-order-id)])
|
||||||
(assert (order title offer (order-id id) (delivery-date "March 9th")))))
|
(set! next-order-id (+ 1 id))
|
||||||
(assert (order title offer #f #f))))))))
|
(assert (order title offer (order-id id) (delivery-date "March 9th"))))
|
||||||
|
(assert (order title offer #f #f)))))))))
|
||||||
|
|
||||||
;; buyer A
|
;; buyer A
|
||||||
(spawn ds-type
|
(spawn ds-type
|
||||||
(facet buyer
|
(lift+define-role buyer-a-impl
|
||||||
(fields [title String "Catch 22"]
|
(start-facet buyer
|
||||||
[budget Int 1000])
|
(field [title String "Catch 22"]
|
||||||
(on (asserted (quote (ref title) (bind answer QuoteAnswer)))
|
[budget Int 1000])
|
||||||
(match answer
|
(on (asserted (quote (ref title) (bind answer QuoteAnswer)))
|
||||||
[(out-of-stock)
|
(match answer
|
||||||
(stop buyer (begin))]
|
[(out-of-stock)
|
||||||
[(price (bind amount Int))
|
(stop buyer)]
|
||||||
(facet negotiation
|
[(price (bind amount Int))
|
||||||
(fields [contribution Int (/ amount 2)])
|
(start-facet negotiation
|
||||||
(on (asserted (split-proposal (ref title) amount (ref contribution) (bind accept? Bool)))
|
(field [contribution Int (/ amount 2)])
|
||||||
(if accept?
|
(on (asserted (split-proposal (ref title) amount (ref contribution) (bind accept? Bool)))
|
||||||
(stop buyer (begin))
|
(if accept?
|
||||||
(if (> (ref contribution) (- amount 5))
|
(stop buyer)
|
||||||
(stop negotiation (displayln "negotiation failed"))
|
(if (> (ref contribution) (- amount 5))
|
||||||
(set! contribution
|
(stop negotiation (displayln "negotiation failed"))
|
||||||
(+ (ref contribution) (/ (- amount (ref contribution)) 2)))))))]))))
|
(set! contribution
|
||||||
|
(+ (ref contribution) (/ (- amount (ref contribution)) 2)))))))])))))
|
||||||
|
|
||||||
;; buyer B
|
;; buyer B
|
||||||
(spawn ds-type
|
(spawn ds-type
|
||||||
(facet buyer-b
|
(lift+define-role buyer-b-impl
|
||||||
(fields [funds Int 5])
|
(start-facet buyer-b
|
||||||
(on (asserted (observe (split-proposal (bind title String) (bind price Int) (bind their-contribution Int) discard)))
|
(field [funds Int 5])
|
||||||
(let [my-contribution (- price their-contribution)]
|
(on (asserted (observe (split-proposal (bind title String) (bind price Int) (bind their-contribution Int) discard)))
|
||||||
(cond
|
(let ([my-contribution (- price their-contribution)])
|
||||||
[(> my-contribution (ref funds))
|
(cond
|
||||||
(facet decline
|
[(> my-contribution (ref funds))
|
||||||
(fields)
|
(start-facet decline
|
||||||
(assert (split-proposal title price their-contribution #f))
|
(assert (split-proposal title price their-contribution #f))
|
||||||
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
||||||
(stop decline (begin))))]
|
(stop decline)))]
|
||||||
[#t
|
[#t
|
||||||
(facet accept
|
(start-facet accept
|
||||||
(fields)
|
(assert (split-proposal title price their-contribution #t))
|
||||||
(assert (split-proposal title price their-contribution #t))
|
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
||||||
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
(stop accept))
|
||||||
(stop accept (begin)))
|
(on start
|
||||||
(on start
|
(spawn ds-type
|
||||||
(spawn ds-type
|
(start-facet purchase
|
||||||
(facet purchase
|
(on (asserted (order title price (bind order-id? (Maybe OrderId)) (bind delivery-date? (Maybe DeliveryDate))))
|
||||||
(fields)
|
(match (tuple order-id? delivery-date?)
|
||||||
(on (asserted (order title price (bind order-id? (Maybe OrderId)) (bind delivery-date? (Maybe DeliveryDate))))
|
[(tuple (order-id (bind id Int)) (delivery-date (bind date String)))
|
||||||
(match (tuple order-id? delivery-date?)
|
;; complete!
|
||||||
[(tuple (order-id (bind id Int)) (delivery-date (bind date String)))
|
(begin (displayln "Completed Order:")
|
||||||
;; complete!
|
(displayln title)
|
||||||
(begin (displayln "Completed Order:")
|
(displayln id)
|
||||||
(displayln title)
|
(displayln date)
|
||||||
(displayln id)
|
(stop purchase))]
|
||||||
(displayln date)
|
[discard
|
||||||
(stop purchase (begin)))]
|
(begin (displayln "Order Rejected")
|
||||||
[discard
|
(stop purchase))]))))))]))))))
|
||||||
(begin (displayln "Order Rejected")
|
)
|
||||||
(stop purchase (begin)))]))))))])))))
|
|
||||||
)
|
(module+ test
|
||||||
|
(check-simulates seller-impl seller-impl)
|
||||||
|
;; found a bug in spec, see seller-role above
|
||||||
|
(check-simulates seller-impl seller-role)
|
||||||
|
(check-simulates buyer-a-impl buyer-a-impl)
|
||||||
|
(check-simulates buyer-b-impl buyer-b-impl))
|
||||||
|
|
|
@ -1,2 +1,2 @@
|
||||||
#lang s-exp syntax/module-reader
|
#lang s-exp syntax/module-reader
|
||||||
typed/main
|
typed/syndicate/roles
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(assertion-struct ping : Ping (v))
|
(assertion-struct ping : Ping (v))
|
||||||
(assertion-struct pong : Pong (v))
|
(assertion-struct pong : Pong (v))
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(run-ground-dataspace (U)
|
(run-ground-dataspace (U)
|
||||||
(spawn (U)
|
(spawn (U)
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue