Browse Source

Hide legacy typed/syndicate #lang, consolidate to the "roles" version

main
Sam Caldwell 9 months ago
parent
commit
c3559f1611
  1. 91
      racket/typed/examples/bank-account.rkt
  2. 2
      racket/typed/examples/book-club.rkt
  3. 2
      racket/typed/examples/cell.rkt
  4. 2
      racket/typed/examples/chat-tcp2.rkt
  5. 4
      racket/typed/examples/file-system.rkt
  6. 0
      racket/typed/examples/flink-support.rkt
  7. 10
      racket/typed/examples/flink.rkt
  8. 2
      racket/typed/examples/internal-knowledge.rkt
  9. 2
      racket/typed/examples/ping-pong.rkt
  10. 4
      racket/typed/examples/provides.rkt
  11. 2
      racket/typed/examples/realize.rkt
  12. 2
      racket/typed/examples/require-struct/client.rkt
  13. 0
      racket/typed/examples/require-struct/driver.rkt
  14. 5
      racket/typed/examples/require:typed/client.rkt
  15. 0
      racket/typed/examples/require:typed/lib.rkt
  16. 5
      racket/typed/examples/requires.rkt
  17. 65
      racket/typed/examples/roles/bank-account.rkt
  18. 5
      racket/typed/examples/roles/require:typed/client.rkt
  19. 5
      racket/typed/examples/roles/requires.rkt
  20. 163
      racket/typed/examples/roles/two-buyer-protocol.rkt
  21. 2
      racket/typed/examples/simple-dataflow.rkt
  22. 2
      racket/typed/examples/simple-dataspace.rkt
  23. 2
      racket/typed/examples/simple-during.rkt
  24. 2
      racket/typed/examples/simple-query-hash.rkt
  25. 2
      racket/typed/examples/simple-query-set.rkt
  26. 2
      racket/typed/examples/simple-query-value.rkt
  27. 2
      racket/typed/examples/simple-stop-facet.rkt
  28. 0
      racket/typed/examples/struct-out/client.rkt
  29. 0
      racket/typed/examples/struct-out/struct-in.rkt
  30. 0
      racket/typed/examples/struct-out/struct-out.rkt
  31. 0
      racket/typed/examples/struct-out/typed-out.rkt
  32. 0
      racket/typed/examples/struct-out/untyped.rkt
  33. 182
      racket/typed/examples/two-buyer-protocol.rkt
  34. 0
      racket/typed/syndicate/first-facet-lang-attempt.rkt
  35. 2
      racket/typed/syndicate/lang/reader.rkt
  36. 2
      racket/typed/tests/basic-bad-assertion.rkt
  37. 2
      racket/typed/tests/comm-ty-composition.rkt
  38. 2
      racket/typed/tests/define-dataflow.rkt
  39. 2
      racket/typed/tests/effect-polymorhpism.rkt
  40. 2
      racket/typed/tests/expressions.rkt
  41. 2
      racket/typed/tests/floating-define.rkt
  42. 2
      racket/typed/tests/for-loop-regression.rkt
  43. 2
      racket/typed/tests/for-loops.rkt
  44. 2
      racket/typed/tests/hashes.rkt
  45. 2
      racket/typed/tests/inference.rkt
  46. 2
      racket/typed/tests/pattern-annotations.rkt
  47. 2
      racket/typed/tests/phantom-rho.rkt
  48. 2
      racket/typed/tests/primitives.rkt
  49. 2
      racket/typed/tests/regression-count-new-words.rkt
  50. 2
      racket/typed/tests/regression-define-with-effects.rkt
  51. 2
      racket/typed/tests/sequences.rkt
  52. 2
      racket/typed/tests/sets.rkt
  53. 2
      racket/typed/tests/spawn.rkt

91
racket/typed/examples/bank-account.rkt

@ -1,14 +1,19 @@
#lang typed/syndicate
;; Expected Output
;; 0
;; 70
;; #f
(define-constructor (account balance)
#:type-constructor AccountT
#:with Account (AccountT Int)
#:with AccountRequest (AccountT ))
#:with AccountRequest (AccountT /t))
(define-constructor (deposit amount)
#:type-constructor DepositT
#:with Deposit (DepositT Int)
#:with DepositRequest (DepositT ))
#:with DepositRequest (DepositT /t))
(define-type-alias ds-type
(U Account
@ -18,45 +23,43 @@
(Observe DepositRequest)
(Observe (Observe DepositRequest))))
(dataspace ds-type
(spawn ds-type
(facet _
(fields [balance Int 0])
(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
(facet _
(fields)
(on (asserted (observe (deposit discard)))
(facet _
(fields)
(assert (deposit 100))
(assert (deposit -30)))))))
#|
;; Hello-worldish "bank account" example.
(struct account (balance) #:prefab)
(struct deposit (amount) #:prefab)
(spawn (field [balance 0])
(assert (account (balance)))
(on (message (deposit $amount))
(balance (+ (balance) amount))))
(spawn (on (asserted (account $balance))
(printf "Balance changed to ~a\n" balance)))
(spawn* (until (asserted (observe (deposit _))))
(send! (deposit +100))
(send! (deposit -30)))
|#
(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)
)

2
racket/typed/examples/roles/book-club.rkt → racket/typed/examples/book-club.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output
;; leader learns that there are 5 copies of The Wind in the Willows

2
racket/typed/examples/roles/cell.rkt → racket/typed/examples/cell.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; adapted from section 8.3 of Tony's dissertation

2
racket/typed/examples/roles/chat-tcp2.rkt → racket/typed/examples/chat-tcp2.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require typed/syndicate/drivers/tcp)

4
racket/typed/examples/roles/file-system.rkt → racket/typed/examples/file-system.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(define-constructor (file name content)
#:type-constructor FileT
@ -31,4 +31,4 @@
(define-type-alias Writer
(Role (writer)
(Sends Save)
(Sends Delete)))
(Sends Delete)))

0
racket/typed/examples/roles/flink-support.rkt → racket/typed/examples/flink-support.rkt

10
racket/typed/examples/roles/flink.rkt → racket/typed/examples/flink.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; ---------------------------------------------------------------------------------------------------
;; Protocol
@ -550,8 +550,8 @@ The JobManager then performs the job and, when finished, asserts
(spawn-client (string->job INPUT)))
(module+ test
(verify-actors (Eventually (A (JobCompletion ID (List InputTask) TaskResult)))
#;(Always (Implies (A (Observe (JobCompletion ID (List InputTask) ★/t)))
#;(verify-actors #;(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))
(Always (Implies (A (Observe (JobCompletion ID (List InputTask) ★/t)))
(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))))
job-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 TaskAssigner)
(check-has-simulating-subgraph job-manager-impl TaskAssigner))
;; infinite loop?
#;(module+ test
(check-simulates job-manager-impl job-manager-impl))

2
racket/typed/examples/roles/internal-knowledge.rkt → racket/typed/examples/internal-knowledge.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output:
#|

2
racket/typed/examples/roles/ping-pong.rkt → racket/typed/examples/ping-pong.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output
;; pong: 8339

4
racket/typed/examples/roles/provides.rkt → racket/typed/examples/provides.rkt

@ -1,8 +1,8 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(provide a-fun)
(define (a-fun [x : Int] -> Int)
(+ x 1))
#;(a-fun 5)
#;(a-fun 5)

2
racket/typed/examples/roles/realize.rkt → racket/typed/examples/realize.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output:
#|

2
racket/typed/examples/roles/require-struct/client.rkt → racket/typed/examples/require-struct/client.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require-struct msg #:as Msg
#:from "driver.rkt")

0
racket/typed/examples/roles/require-struct/driver.rkt → racket/typed/examples/require-struct/driver.rkt

5
racket/typed/examples/require:typed/client.rkt

@ -0,0 +1,5 @@
#lang typed/syndicate
(require/typed "lib.rkt" [x : Int])
(displayln (+ x 1))

0
racket/typed/examples/roles/require:typed/lib.rkt → racket/typed/examples/require:typed/lib.rkt

5
racket/typed/examples/requires.rkt

@ -0,0 +1,5 @@
#lang typed/syndicate
(require "provides.rkt")
(a-fun 5)

65
racket/typed/examples/roles/bank-account.rkt

@ -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)
)

5
racket/typed/examples/roles/require:typed/client.rkt

@ -1,5 +0,0 @@
#lang typed/syndicate/roles
(require/typed "lib.rkt" [x : Int])
(displayln (+ x 1))

5
racket/typed/examples/roles/requires.rkt

@ -1,5 +0,0 @@
#lang typed/syndicate/roles
(require "provides.rkt")
(a-fun 5)

163
racket/typed/examples/roles/two-buyer-protocol.rkt

@ -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))

2
racket/typed/examples/roles/simple-dataflow.rkt → racket/typed/examples/simple-dataflow.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output
;; f: 0

2
racket/typed/examples/roles/simple-dataspace.rkt → racket/typed/examples/simple-dataspace.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(run-ground-dataspace Int
(spawn Int

2
racket/typed/examples/roles/simple-during.rkt → racket/typed/examples/simple-during.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output
;; +GO

2
racket/typed/examples/roles/simple-query-hash.rkt → racket/typed/examples/simple-query-hash.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output
;; adding key2 -> 88

2
racket/typed/examples/roles/simple-query-set.rkt → racket/typed/examples/simple-query-set.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output
;; size: 0

2
racket/typed/examples/roles/simple-query-value.rkt → racket/typed/examples/simple-query-value.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output
;; query: 0

2
racket/typed/examples/roles/simple-stop-facet.rkt → racket/typed/examples/simple-stop-facet.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
;; Expected Output:
;; +42

0
racket/typed/examples/roles/struct-out/client.rkt → racket/typed/examples/struct-out/client.rkt

0
racket/typed/examples/roles/struct-out/struct-in.rkt → racket/typed/examples/struct-out/struct-in.rkt

0
racket/typed/examples/roles/struct-out/struct-out.rkt → racket/typed/examples/struct-out/struct-out.rkt

0
racket/typed/examples/roles/struct-out/typed-out.rkt → racket/typed/examples/struct-out/typed-out.rkt

0
racket/typed/examples/roles/struct-out/untyped.rkt → racket/typed/examples/struct-out/untyped.rkt

182
racket/typed/examples/two-buyer-protocol.rkt

@ -20,14 +20,14 @@
(define-constructor (quote title answer)
#:type-constructor QuoteT
#:with Quote (QuoteT String QuoteAnswer)
#:with QuoteRequest (Observe (QuoteT String ))
#:with QuoteInterest (Observe (QuoteT )))
#: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 ))
#:with SplitInterest (Observe (SplitProposalT )))
#:with SplitRequest (Observe (SplitProposalT String Int Int /t))
#:with SplitInterest (Observe (SplitProposalT /t /t /t /t)))
(define-constructor (order-id id)
#:type-constructor OrderIdT
@ -40,11 +40,11 @@
(define-type-alias (Maybe t)
(U t Bool))
(define-constructor (order title price id delivery-date)
(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 ))
#:with OrderInterest (Observe (OrderT )))
#:with OrderRequest (Observe (OrderT String Int /t /t))
#:with OrderInterest (Observe (OrderT /t /t /t /t)))
(define-type-alias ds-type
(U ;; quotes
@ -60,88 +60,104 @@
OrderRequest
(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
(spawn ds-type
(facet _
(fields [book (Tuple String Int) (tuple "Catch 22" 22)]
[next-order-id Int 10001483])
(on (asserted (observe (quote (bind title String) discard)))
(facet x
(fields)
(on (retracted (observe (quote title discard)))
(stop x (begin)))
(match title
["Catch 22"
(assert (quote title (price 22)))]
[discard
(assert (quote title (out-of-stock)))])))
(on (asserted (observe (order (bind title String) (bind offer Int) discard discard)))
(facet x
(fields)
(on (retracted (observe (order title offer discard discard)))
(stop x (begin)))
(let [asking-price 22]
(if (and (equal? title "Catch 22") (>= offer asking-price))
(let [id (ref next-order-id)]
(begin (set! next-order-id (+ 1 id))
(assert (order title offer (order-id id) (delivery-date "March 9th")))))
(assert (order title offer #f #f))))))))
(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
(facet buyer
(fields [title String "Catch 22"]
[budget Int 1000])
(on (asserted (quote (ref title) (bind answer QuoteAnswer)))
(match answer
[(out-of-stock)
(stop buyer (begin))]
[(price (bind amount Int))
(facet negotiation
(fields [contribution Int (/ amount 2)])
(on (asserted (split-proposal (ref title) amount (ref contribution) (bind accept? Bool)))
(if accept?
(stop buyer (begin))
(if (> (ref contribution) (- amount 5))
(stop negotiation (displayln "negotiation failed"))
(set! contribution
(+ (ref contribution) (/ (- amount (ref contribution)) 2)))))))]))))
(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
(facet buyer-b
(fields [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))
(facet decline
(fields)
(assert (split-proposal title price their-contribution #f))
(on (retracted (observe (split-proposal title price their-contribution discard)))
(stop decline (begin))))]
[#t
(facet accept
(fields)
(assert (split-proposal title price their-contribution #t))
(on (retracted (observe (split-proposal title price their-contribution discard)))
(stop accept (begin)))
(on start
(spawn ds-type
(facet purchase
(fields)
(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 (begin)))]
[discard
(begin (displayln "Order Rejected")
(stop purchase (begin)))]))))))])))))
)
(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))

0
racket/typed/main.rkt → racket/typed/syndicate/first-facet-lang-attempt.rkt

2
racket/typed/syndicate/lang/reader.rkt

@ -1,2 +1,2 @@
#lang s-exp syntax/module-reader
typed/main
typed/syndicate/roles

2
racket/typed/tests/basic-bad-assertion.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/comm-ty-composition.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(assertion-struct ping : Ping (v))
(assertion-struct pong : Pong (v))

2
racket/typed/tests/define-dataflow.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(run-ground-dataspace (U)
(spawn (U)

2
racket/typed/tests/effect-polymorhpism.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/expressions.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/floating-define.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/for-loop-regression.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/for-loops.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/hashes.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/inference.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/pattern-annotations.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/phantom-rho.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/primitives.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/regression-count-new-words.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/regression-define-with-effects.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/sequences.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/sets.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

2
racket/typed/tests/spawn.rkt

@ -1,4 +1,4 @@
#lang typed/syndicate/roles
#lang typed/syndicate
(require rackunit/turnstile)

Loading…
Cancel
Save