Compare commits
322 Commits
Author | SHA1 | Date |
---|---|---|
Sam Caldwell | 0226b74305 | |
Sam Caldwell | 1607f7df45 | |
Sam Caldwell | e9703a4189 | |
Sam Caldwell | a0e8b59299 | |
Sam Caldwell | 042d667311 | |
Sam Caldwell | 2f17f77d31 | |
Sam Caldwell | b273586616 | |
Sam Caldwell | 26f15564f1 | |
Sam Caldwell | 3801174525 | |
Sam Caldwell | 4ab405fd70 | |
Sam Caldwell | e514453a12 | |
Sam Caldwell | c78cf5bb3d | |
Sam Caldwell | 59042f9180 | |
Sam Caldwell | 28b8bf742f | |
Sam Caldwell | 4808004d64 | |
Sam Caldwell | 45425eb68d | |
Sam Caldwell | 2064bd8f00 | |
Sam Caldwell | 6a7879c06e | |
Sam Caldwell | 643cc4d3ab | |
Sam Caldwell | e4ca56a002 | |
Sam Caldwell | 8af4464443 | |
Sam Caldwell | 0d839cbb12 | |
Sam Caldwell | 7a50ed2f5e | |
Sam Caldwell | 899fe287b4 | |
Sam Caldwell | 3d9b1c383c | |
Sam Caldwell | 7f54c4ccd0 | |
Sam Caldwell | 43cc25ea1b | |
Sam Caldwell | 798e66dc8c | |
Sam Caldwell | 2fb7f4795e | |
Sam Caldwell | b8d580faf3 | |
Sam Caldwell | 28e89297f9 | |
Sam Caldwell | a5e6caaa52 | |
Sam Caldwell | 2057a9f5a9 | |
Sam Caldwell | 3bdace6535 | |
Sam Caldwell | e42460b5e6 | |
Sam Caldwell | 788c9b0e46 | |
Sam Caldwell | c9b25df034 | |
Sam Caldwell | b9f655766f | |
Sam Caldwell | d2e753d303 | |
Sam Caldwell | 29b1171aa8 | |
Sam Caldwell | fc038877f5 | |
Sam Caldwell | e4f72519f0 | |
Sam Caldwell | 2327648499 | |
Sam Caldwell | 6985022a4b | |
Sam Caldwell | ce965d9025 | |
Sam Caldwell | 384d0dbdc1 | |
Sam Caldwell | 06aa3690c7 | |
Sam Caldwell | 6058330961 | |
Sam Caldwell | fe798f72a1 | |
Sam Caldwell | f5f15a5728 | |
Sam Caldwell | 98b773e7ee | |
Sam Caldwell | b4497f1623 | |
Sam Caldwell | 9952ff9400 | |
Sam Caldwell | fd59e58dc3 | |
Sam Caldwell | 481b490fd2 | |
Sam Caldwell | 3ec1048aad | |
Sam Caldwell | 55477446c2 | |
Sam Caldwell | 50cac93e1e | |
Sam Caldwell | fc6e012d1c | |
Sam Caldwell | 3b75881366 | |
Sam Caldwell | 690f9e65a8 | |
Sam Caldwell | 4f6089c805 | |
Sam Caldwell | aa74ffa14d | |
Sam Caldwell | 09ce074125 | |
Sam Caldwell | 3f6a5573e4 | |
Sam Caldwell | 98c58d3e6f | |
Sam Caldwell | c3559f1611 | |
Sam Caldwell | 8b67d0ba03 | |
Sam Caldwell | 52e64d6792 | |
Sam Caldwell | 59183b5fe9 | |
Sam Caldwell | 0191461137 | |
Sam Caldwell | 6b46be34f9 | |
Sam Caldwell | ff1ac58a36 | |
Sam Caldwell | c54b088a4d | |
Sam Caldwell | d5894e400b | |
Sam Caldwell | b023753091 | |
Sam Caldwell | 04530893f4 | |
Sam Caldwell | bd267cfaa9 | |
Sam Caldwell | d79378b4a3 | |
Sam Caldwell | 7a8628880a | |
Sam Caldwell | 145bc84e33 | |
Sam Caldwell | 549590d304 | |
Sam Caldwell | cb3f0546c0 | |
Sam Caldwell | 4e43c489d8 | |
Sam Caldwell | d0f00779cd | |
Sam Caldwell | 5a5c651321 | |
Sam Caldwell | 1fba368987 | |
Sam Caldwell | 7475c1896f | |
Sam Caldwell | 5a90933e9f | |
Sam Caldwell | 8dda1ba6bf | |
Sam Caldwell | 45f140d642 | |
Sam Caldwell | 95699308dd | |
Sam Caldwell | 362e102524 | |
Sam Caldwell | 78fee55ffa | |
Sam Caldwell | 2fd3771609 | |
Sam Caldwell | 8be62ed72c | |
Sam Caldwell | c9c2d2747b | |
Sam Caldwell | c20d075d03 | |
Sam Caldwell | 6dd369b08f | |
Sam Caldwell | c9a5af0d10 | |
Sam Caldwell | 7d8b62ff02 | |
Sam Caldwell | db2a8e1cec | |
Sam Caldwell | 3e13e3e449 | |
Sam Caldwell | 8a6931710a | |
Sam Caldwell | 1805b936be | |
Sam Caldwell | 25860019c6 | |
Sam Caldwell | abecc4996c | |
Sam Caldwell | d523dc7937 | |
Sam Caldwell | e75af5ae1c | |
Sam Caldwell | 4cd90a6295 | |
Sam Caldwell | f040a6db7e | |
Sam Caldwell | e5b797b450 | |
Sam Caldwell | bdf4c30218 | |
Sam Caldwell | 04b58f9d9f | |
Sam Caldwell | b66ab0bfcd | |
Sam Caldwell | 733c874871 | |
Sam Caldwell | fe6435f056 | |
Sam Caldwell | 659715cd0e | |
Sam Caldwell | 8446a0d770 | |
Sam Caldwell | 8288312890 | |
Sam Caldwell | 967da40b80 | |
Sam Caldwell | 1e434f8006 | |
Michael Ballantyne | c988c4f462 | |
Sam Caldwell | db3fc2acd9 | |
Michael Ballantyne | 50d2d1a6fa | |
Sam Caldwell | 122ef0b5f9 | |
Sam Caldwell | e1ca7ba2c4 | |
Sam Caldwell | 27b83e5e0a | |
Sam Caldwell | a1660114df | |
Sam Caldwell | 074ec24da4 | |
Sam Caldwell | 48344856c3 | |
Sam Caldwell | 165dfeb6c8 | |
Sam Caldwell | 38b5e34efb | |
Sam Caldwell | e2bb438704 | |
Sam Caldwell | a6fc1f20e4 | |
Sam Caldwell | 04995b5fb3 | |
Sam Caldwell | 2ba5366986 | |
Sam Caldwell | fc4413ec7a | |
Sam Caldwell | 2cdb894728 | |
Sam Caldwell | 0ed975c58c | |
Sam Caldwell | b59db5b3fd | |
Sam Caldwell | 2a589fcc18 | |
Sam Caldwell | dcd53f5dd5 | |
Sam Caldwell | 0d11850295 | |
Sam Caldwell | 7cf8f9fc0a | |
Sam Caldwell | d30007b798 | |
Sam Caldwell | a5dd55b907 | |
Sam Caldwell | 7e5c8e8eb7 | |
Sam Caldwell | 13e2ec7594 | |
Sam Caldwell | 2e9a0f6394 | |
Sam Caldwell | 5434e82299 | |
Sam Caldwell | 0999c9b75b | |
Sam Caldwell | 30430c391b | |
Sam Caldwell | 060ca752f3 | |
Sam Caldwell | af8dbeaa4b | |
Sam Caldwell | 35d3332698 | |
Sam Caldwell | 9b48e77b6d | |
Sam Caldwell | cc8d0fa30b | |
Sam Caldwell | 98c5c96356 | |
Sam Caldwell | 026e129de7 | |
Sam Caldwell | a2780484be | |
Sam Caldwell | 5c8986bddd | |
Sam Caldwell | 6c79e5cd5c | |
Sam Caldwell | 7ceed8e952 | |
Sam Caldwell | dca8ea2bad | |
Sam Caldwell | b8b5a1747a | |
Sam Caldwell | c38a47f5e3 | |
Sam Caldwell | 480feb961c | |
Sam Caldwell | f8c385e31d | |
Sam Caldwell | dee43c7f19 | |
Sam Caldwell | 18932662de | |
Sam Caldwell | 013ce19e68 | |
Sam Caldwell | f4701a3f70 | |
Stephen Chang | 056d467402 | |
Sam Caldwell | f19d2f3296 | |
Sam Caldwell | f3e2fcdc64 | |
Sam Caldwell | 2a95420366 | |
Sam Caldwell | 7cf0757ca6 | |
Sam Caldwell | 5823cf32c3 | |
Sam Caldwell | 18fdcdeff7 | |
Sam Caldwell | 90961e57f8 | |
Sam Caldwell | 6f8c9563aa | |
Sam Caldwell | 14db8ce919 | |
Sam Caldwell | 79277c91d3 | |
Sam Caldwell | e3d9f93eca | |
Sam Caldwell | 5f472b5402 | |
Sam Caldwell | 35827c970c | |
Sam Caldwell | 8bbab5317e | |
Sam Caldwell | ab15f7306f | |
Sam Caldwell | 606dd17e08 | |
Sam Caldwell | 32ebb804fb | |
Sam Caldwell | 3459fc8f71 | |
Sam Caldwell | 0a5ea2b920 | |
Sam Caldwell | e3d746b817 | |
Sam Caldwell | ed7c212561 | |
Sam Caldwell | 4e6b883c17 | |
Sam Caldwell | c9c3b9ec82 | |
Sam Caldwell | 9c0c9b3e77 | |
Sam Caldwell | 6ee5aa668b | |
Sam Caldwell | ecbfe56163 | |
Sam Caldwell | 7af6782ea8 | |
Sam Caldwell | ce9d563d8c | |
Sam Caldwell | 9e88cde0eb | |
Sam Caldwell | e554c797fb | |
Sam Caldwell | 89e42ae987 | |
Sam Caldwell | 161abab986 | |
Sam Caldwell | ce0dba8f36 | |
Sam Caldwell | 5a5fb74124 | |
Sam Caldwell | 9f8469467a | |
Sam Caldwell | 123124acb2 | |
Sam Caldwell | 7ba1ecf055 | |
Sam Caldwell | 5a19594fa1 | |
Sam Caldwell | 2a72f63084 | |
Sam Caldwell | 63c36d7010 | |
Sam Caldwell | d4b17154eb | |
Sam Caldwell | 5da04741f2 | |
Sam Caldwell | 4d6878626c | |
Sam Caldwell | 712dbd12c9 | |
Sam Caldwell | 9cdaf768d8 | |
Sam Caldwell | de88dc3c83 | |
Sam Caldwell | 5c6b473b62 | |
Sam Caldwell | b3cb16192c | |
Sam Caldwell | 945256b567 | |
Sam Caldwell | cefe70c590 | |
Sam Caldwell | e0d1975e2d | |
Sam Caldwell | d8516060c4 | |
Sam Caldwell | a1ca2372a5 | |
Sam Caldwell | 426b0899ac | |
Sam Caldwell | 1cd46da9d0 | |
Sam Caldwell | 1450665dc0 | |
Sam Caldwell | 9893f4dea1 | |
Sam Caldwell | 7dd9700c99 | |
Sam Caldwell | a41cee09bf | |
Sam Caldwell | 0d4f8df3b4 | |
Sam Caldwell | 116dcefc1a | |
Sam Caldwell | 9b4f76b0ac | |
Sam Caldwell | 989c6af818 | |
Sam Caldwell | d9da970742 | |
Sam Caldwell | 5d922fe030 | |
Sam Caldwell | c1190958bd | |
Sam Caldwell | 57d641dcc3 | |
Sam Caldwell | 397bebe4a3 | |
Sam Caldwell | b0ff2e8620 | |
Sam Caldwell | 6230ed577e | |
Sam Caldwell | 7994bfb9c6 | |
Sam Caldwell | 227768efd8 | |
Sam Caldwell | f20adacfde | |
Sam Caldwell | 67e0eebdc2 | |
Sam Caldwell | 7445626d0b | |
Sam Caldwell | 6778417639 | |
Sam Caldwell | b7ec18e52d | |
Sam Caldwell | 89ce5dca28 | |
Sam Caldwell | b1d14d8559 | |
Sam Caldwell | 7026d6908d | |
Sam Caldwell | 292e16f8b8 | |
Sam Caldwell | 60c58d2b7b | |
Sam Caldwell | d91f13bd2c | |
Sam Caldwell | 5965115611 | |
Sam Caldwell | adc0819be0 | |
Sam Caldwell | 49b34268ad | |
Sam Caldwell | d5a8d27ae3 | |
Sam Caldwell | 4e335f8049 | |
Sam Caldwell | d236d99d47 | |
Sam Caldwell | a0a30c719a | |
Sam Caldwell | cf2162797a | |
Sam Caldwell | 7b9595a22a | |
Sam Caldwell | 667231d3e8 | |
Sam Caldwell | 6b58c20832 | |
Sam Caldwell | b9e99fc8af | |
Sam Caldwell | 45e7ea609d | |
Sam Caldwell | f6976c0281 | |
Sam Caldwell | 0752089101 | |
Sam Caldwell | ad4b94422d | |
Sam Caldwell | b56319042c | |
Sam Caldwell | f4f517cd02 | |
Sam Caldwell | c9378d057d | |
Sam Caldwell | 9cb884a490 | |
Sam Caldwell | e7f792e624 | |
Sam Caldwell | f1be0fdfac | |
Sam Caldwell | 93e1fea202 | |
Sam Caldwell | 16ce86c6c9 | |
Sam Caldwell | c097e218d0 | |
Sam Caldwell | 12fd4ad756 | |
Sam Caldwell | f460011a5d | |
Sam Caldwell | 51e26efda6 | |
Sam Caldwell | 122f7629c3 | |
Sam Caldwell | c96725b8e3 | |
Sam Caldwell | 1feab5d174 | |
Sam Caldwell | 530c17ff32 | |
Sam Caldwell | ed01517c8c | |
Sam Caldwell | 10ae47c26c | |
Sam Caldwell | 6f52c7fc61 | |
Sam Caldwell | 9d5453ff5b | |
Sam Caldwell | f00ec81e48 | |
Sam Caldwell | b1cca8f377 | |
Sam Caldwell | cf17ae28a5 | |
Sam Caldwell | f6cd87394e | |
Sam Caldwell | 39d81686fd | |
Sam Caldwell | 2ddafb240a | |
Sam Caldwell | e88b64f5c1 | |
Sam Caldwell | 82705763b4 | |
Sam Caldwell | 581319eacb | |
Sam Caldwell | 3c800a92db | |
Sam Caldwell | 29c446df39 | |
Sam Caldwell | 006e5e0bf5 | |
Sam Caldwell | f9dcad855e | |
Sam Caldwell | fa7af3444c | |
Sam Caldwell | 58c1b52ac4 | |
Sam Caldwell | d5ac65007e | |
Sam Caldwell | 572be6b45d | |
Sam Caldwell | 5752c9299c | |
Sam Caldwell | 7dfc4a93da | |
Sam Caldwell | ff81748848 | |
Sam Caldwell | f0c52f6eaa | |
Sam Caldwell | e141abd678 | |
Sam Caldwell | d285de5bb2 | |
Sam Caldwell | 04f4acbda3 | |
Sam Caldwell | abce2d6046 | |
Sam Caldwell | d35495029b | |
Tony Garnock-Jones | 38f6351d43 | |
Tony Garnock-Jones | cd98c3048d | |
Tony Garnock-Jones | d1fbe26bc1 |
|
@ -1,30 +1,43 @@
|
||||||
#lang setup/infotab
|
#lang setup/infotab
|
||||||
(define collection 'multi)
|
(define collection 'multi)
|
||||||
(define deps '("rfc6455"
|
(define deps '(
|
||||||
"turnstile-lib"
|
|
||||||
"turnstile-example"
|
|
||||||
"macrotypes-lib"
|
|
||||||
"rackunit-macrotypes-lib"
|
|
||||||
"base"
|
"base"
|
||||||
"data-lib"
|
"data-lib"
|
||||||
|
"htdp-lib"
|
||||||
"net-lib"
|
"net-lib"
|
||||||
"web-server-lib"
|
|
||||||
"profile-lib"
|
"profile-lib"
|
||||||
"rackunit-lib"
|
"rackunit-lib"
|
||||||
"htdp-lib"
|
"sha"
|
||||||
|
"automata"
|
||||||
|
"auxiliary-macro-context"
|
||||||
"data-enumerate-lib"
|
"data-enumerate-lib"
|
||||||
"datalog"
|
"datalog"
|
||||||
|
"db-lib"
|
||||||
"draw-lib"
|
"draw-lib"
|
||||||
"gui-lib"
|
"gui-lib"
|
||||||
|
"images-lib"
|
||||||
|
"macrotypes-lib"
|
||||||
"pict-lib"
|
"pict-lib"
|
||||||
|
"rackunit-macrotypes-lib"
|
||||||
|
"rfc6455"
|
||||||
|
"sandbox-lib"
|
||||||
"sgl"
|
"sgl"
|
||||||
"struct-defaults"
|
"struct-defaults"
|
||||||
"auxiliary-macro-context"
|
"turnstile-example"
|
||||||
"sandbox-lib"
|
"turnstile-lib"
|
||||||
"images-lib"
|
"web-server-lib"
|
||||||
"automata"
|
))
|
||||||
"sha"))
|
(define build-deps '(
|
||||||
(define build-deps '("racket-doc"
|
"draw-doc"
|
||||||
|
"gui-doc"
|
||||||
|
"htdp-doc"
|
||||||
|
"pict-doc"
|
||||||
|
"racket-doc"
|
||||||
"scribble-lib"
|
"scribble-lib"
|
||||||
"sha"
|
"sha"
|
||||||
"draw-doc" "gui-doc" "htdp-doc" "pict-doc"))
|
))
|
||||||
|
|
||||||
|
(define test-omit-paths
|
||||||
|
;; There's some shared library related build issue with the syndicate-gl things
|
||||||
|
'("syndicate-gl/"
|
||||||
|
"syndicate-ide/"))
|
||||||
|
|
|
@ -2,3 +2,7 @@
|
||||||
|
|
||||||
(define compile-omit-paths
|
(define compile-omit-paths
|
||||||
'("examples"))
|
'("examples"))
|
||||||
|
|
||||||
|
(define test-omit-paths
|
||||||
|
'(;; depends on Matthias's 7GUI project which is not on the package server
|
||||||
|
"examples"))
|
||||||
|
|
|
@ -409,6 +409,7 @@
|
||||||
[(_ [id:id init maybe-contract ...] ...)
|
[(_ [id:id init maybe-contract ...] ...)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(begin
|
(begin
|
||||||
|
(ensure-in-endpoint-context! 'field)
|
||||||
(when (and (in-script?) (pair? (current-facet-id)))
|
(when (and (in-script?) (pair? (current-facet-id)))
|
||||||
(error 'field
|
(error 'field
|
||||||
"~a: Cannot declare fields in a script; are you missing a (react ...)?"
|
"~a: Cannot declare fields in a script; are you missing a (react ...)?"
|
||||||
|
@ -487,13 +488,17 @@
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ script ...)
|
[(_ script ...)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(schedule-script! (lambda () (begin/void-default script ...))))]))
|
(begin
|
||||||
|
(ensure-in-endpoint-context! 'on-start)
|
||||||
|
(schedule-script! (lambda () (begin/void-default script ...)))))]))
|
||||||
|
|
||||||
(define-syntax (on-stop stx)
|
(define-syntax (on-stop stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ script ...)
|
[(_ script ...)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(add-stop-script! (lambda () (begin/void-default script ...))))]))
|
(begin
|
||||||
|
(ensure-in-endpoint-context! 'on-stop)
|
||||||
|
(add-stop-script! (lambda () (begin/void-default script ...)))))]))
|
||||||
|
|
||||||
(define-syntax (on-event stx)
|
(define-syntax (on-event stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -798,7 +803,7 @@
|
||||||
#:macro-definer-name define-event-expander
|
#:macro-definer-name define-event-expander
|
||||||
#:introducer-parameter-name current-event-expander-introducer
|
#:introducer-parameter-name current-event-expander-introducer
|
||||||
#:local-introduce-name syntax-local-event-expander-introduce
|
#:local-introduce-name syntax-local-event-expander-introduce
|
||||||
#:expander-id-predicate-name event-expander-id?
|
#:expander-form-predicate-name event-expander-form?
|
||||||
#:expander-transform-name event-expander-transform)
|
#:expander-transform-name event-expander-transform)
|
||||||
|
|
||||||
(provide (for-syntax
|
(provide (for-syntax
|
||||||
|
@ -806,7 +811,7 @@
|
||||||
event-expander?
|
event-expander?
|
||||||
event-expander-proc
|
event-expander-proc
|
||||||
syntax-local-event-expander-introduce
|
syntax-local-event-expander-introduce
|
||||||
event-expander-id?
|
event-expander-form?
|
||||||
event-expander-transform)
|
event-expander-transform)
|
||||||
define-event-expander)
|
define-event-expander)
|
||||||
|
|
||||||
|
@ -856,6 +861,12 @@
|
||||||
(if internal? #`(internal-knowledge #,P-stx) P-stx))
|
(if internal? #`(internal-knowledge #,P-stx) P-stx))
|
||||||
(define-values (proj-stx pat bindings _instantiated)
|
(define-values (proj-stx pat bindings _instantiated)
|
||||||
(analyze-pattern event-stx P+))
|
(analyze-pattern event-stx P+))
|
||||||
|
(define interest-stx
|
||||||
|
(if internal?
|
||||||
|
#`(patch-seq (core:sub #,pat)
|
||||||
|
;; Allow other facets to see our interest
|
||||||
|
(core:assert (internal-knowledge (observe #,(cadr pat)))))
|
||||||
|
#`(core:sub #,pat)))
|
||||||
(define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?))
|
(define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?))
|
||||||
(define patch-accessor-stx (if asserted? #'patch-added #'patch-removed))
|
(define patch-accessor-stx (if asserted? #'patch-added #'patch-removed))
|
||||||
(define change-detector-stx
|
(define change-detector-stx
|
||||||
|
@ -867,7 +878,7 @@
|
||||||
#,(source-location->string outer-expr-stx)
|
#,(source-location->string outer-expr-stx)
|
||||||
#,internal?
|
#,internal?
|
||||||
(lambda () (if #,when-pred-stx
|
(lambda () (if #,when-pred-stx
|
||||||
(core:sub #,pat)
|
#,interest-stx
|
||||||
patch-empty))
|
patch-empty))
|
||||||
(lambda (e current-interests synthetic?)
|
(lambda (e current-interests synthetic?)
|
||||||
(when (not (trie-empty? current-interests))
|
(when (not (trie-empty? current-interests))
|
||||||
|
@ -938,8 +949,8 @@
|
||||||
(define event-stx (syntax-disarm armed-event-stx orig-insp))
|
(define event-stx (syntax-disarm armed-event-stx orig-insp))
|
||||||
(syntax-parse event-stx
|
(syntax-parse event-stx
|
||||||
#:literals [core:message asserted retracted rising-edge know forget realize]
|
#:literals [core:message asserted retracted rising-edge know forget realize]
|
||||||
[(expander args ...)
|
[expander
|
||||||
#:when (event-expander-id? #'expander)
|
#:when (event-expander-form? #'expander)
|
||||||
(event-expander-transform
|
(event-expander-transform
|
||||||
event-stx
|
event-stx
|
||||||
(lambda (result)
|
(lambda (result)
|
||||||
|
@ -1110,11 +1121,12 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Endpoint Creation
|
;; Endpoint Creation
|
||||||
|
|
||||||
|
(define (ensure-in-endpoint-context! who)
|
||||||
|
(when (or (in-script?) (null? (current-facet-id)))
|
||||||
|
(error who "Attempt to add endpoint out of installation context; are you missing a (react ...)?")))
|
||||||
|
|
||||||
(define (add-endpoint! where internal? patch-fn handler-fn)
|
(define (add-endpoint! where internal? patch-fn handler-fn)
|
||||||
(when (in-script?)
|
(ensure-in-endpoint-context! 'add-endpoint!)
|
||||||
(error 'add-endpoint!
|
|
||||||
"~a: Cannot add endpoint in script; are you missing a (react ...)?"
|
|
||||||
where))
|
|
||||||
(define-values (new-eid delta-aggregate)
|
(define-values (new-eid delta-aggregate)
|
||||||
(let ()
|
(let ()
|
||||||
(define a (current-actor-state))
|
(define a (current-actor-state))
|
||||||
|
@ -1200,12 +1212,9 @@
|
||||||
(dataflow-forget-subject! (actor-state-field-dataflow a) (list fid eid))
|
(dataflow-forget-subject! (actor-state-field-dataflow a) (list fid eid))
|
||||||
(define-values (new-mux _eid _delta delta-aggregate)
|
(define-values (new-mux _eid _delta delta-aggregate)
|
||||||
(mux-remove-stream (actor-state-mux a) eid))
|
(mux-remove-stream (actor-state-mux a) eid))
|
||||||
(define internal (patch-step delta-aggregate internal-knowledge-parenthesis))
|
(define-values (internal external) (split-internal/external delta-aggregate))
|
||||||
(define external (patch (trie-subtract (patch-added delta-aggregate) (patch-added internal))
|
|
||||||
(trie-subtract (patch-removed delta-aggregate) (patch-removed internal))))
|
|
||||||
(current-actor-state (struct-copy actor-state a
|
(current-actor-state (struct-copy actor-state a
|
||||||
[mux new-mux]))
|
[mux new-mux]))
|
||||||
(define internal-aggregate (patch-prepend internal-knowledge-parenthesis internal))
|
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
#:priority *gc-priority*
|
#:priority *gc-priority*
|
||||||
;; need to do this later for the forget change detector
|
;; need to do this later for the forget change detector
|
||||||
|
@ -1216,7 +1225,7 @@
|
||||||
(current-actor-state (struct-copy actor-state a
|
(current-actor-state (struct-copy actor-state a
|
||||||
[knowledge new-knowledge]))))
|
[knowledge new-knowledge]))))
|
||||||
|
|
||||||
(schedule-internal-event! internal-aggregate)
|
(schedule-internal-event! internal)
|
||||||
(schedule-action! external))))
|
(schedule-action! external))))
|
||||||
|
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
|
@ -1328,7 +1337,9 @@
|
||||||
(define-values (new-mux _eid _delta delta-aggregate)
|
(define-values (new-mux _eid _delta delta-aggregate)
|
||||||
(mux-update-stream (actor-state-mux a) eid patch))
|
(mux-update-stream (actor-state-mux a) eid patch))
|
||||||
(current-actor-state (struct-copy actor-state a [mux new-mux]))
|
(current-actor-state (struct-copy actor-state a [mux new-mux]))
|
||||||
(schedule-action! delta-aggregate))
|
(define-values (internal external) (split-internal/external delta-aggregate))
|
||||||
|
(schedule-internal-event! internal)
|
||||||
|
(schedule-action! external))
|
||||||
|
|
||||||
(define (actor-behavior e a)
|
(define (actor-behavior e a)
|
||||||
(and e
|
(and e
|
||||||
|
@ -1352,9 +1363,7 @@
|
||||||
(define mux (actor-state-mux (current-actor-state)))
|
(define mux (actor-state-mux (current-actor-state)))
|
||||||
(with-current-facet fid #f
|
(with-current-facet fid #f
|
||||||
(when (patch? e)
|
(when (patch? e)
|
||||||
;; quick-and-dirty intersection with (internal-knowledge ?)
|
(define internal (internal-patch e))
|
||||||
(define internal (patch-prepend internal-knowledge-parenthesis
|
|
||||||
(patch-step e internal-knowledge-parenthesis)))
|
|
||||||
(update-facet! fid
|
(update-facet! fid
|
||||||
(lambda (f)
|
(lambda (f)
|
||||||
(and f
|
(and f
|
||||||
|
@ -1492,6 +1501,23 @@
|
||||||
(ensure-in-script! 'quit-dataspace!)
|
(ensure-in-script! 'quit-dataspace!)
|
||||||
(schedule-action! (core:quit-dataspace)))
|
(schedule-action! (core:quit-dataspace)))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Helpers
|
||||||
|
|
||||||
|
;; Patch -> (Values Patch Patch)
|
||||||
|
;; split a patch into its internal and external components
|
||||||
|
(define (split-internal/external e)
|
||||||
|
(define internal (internal-patch e))
|
||||||
|
(values internal
|
||||||
|
(patch (trie-subtract (patch-added e) (patch-added internal))
|
||||||
|
(trie-subtract (patch-removed e) (patch-removed internal)))))
|
||||||
|
|
||||||
|
;; Patch -> Patch
|
||||||
|
;; Remove all items from a patch not constructed with internal-knowledge
|
||||||
|
(define (internal-patch e)
|
||||||
|
(patch-prepend internal-knowledge-parenthesis
|
||||||
|
(patch-step e internal-knowledge-parenthesis)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (format-field-descriptor d)
|
(define (format-field-descriptor d)
|
||||||
|
|
|
@ -8,6 +8,7 @@
|
||||||
(require "main.rkt")
|
(require "main.rkt")
|
||||||
(require (submod "actor.rkt" for-module-begin))
|
(require (submod "actor.rkt" for-module-begin))
|
||||||
(require "store.rkt")
|
(require "store.rkt")
|
||||||
|
(require (only-in "core.rkt" clean-actions))
|
||||||
|
|
||||||
(provide (rename-out [module-begin #%module-begin])
|
(provide (rename-out [module-begin #%module-begin])
|
||||||
activate
|
activate
|
||||||
|
@ -71,6 +72,13 @@
|
||||||
#%declare
|
#%declare
|
||||||
begin-for-declarations))))
|
begin-for-declarations))))
|
||||||
|
|
||||||
|
(define (ensure-spawn-actions! acts)
|
||||||
|
(define cleaned-acts (clean-actions acts))
|
||||||
|
(for ([act (in-list cleaned-acts)]
|
||||||
|
#:unless (actor? act))
|
||||||
|
(raise-argument-error 'syndicate-module "top-level actor creation action" act))
|
||||||
|
cleaned-acts)
|
||||||
|
|
||||||
(define-syntax (syndicate-module stx)
|
(define-syntax (syndicate-module stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ (action-ids ...) (form forms ...))
|
[(_ (action-ids ...) (form forms ...))
|
||||||
|
@ -89,8 +97,9 @@
|
||||||
#`(begin
|
#`(begin
|
||||||
(define-values (tmp ...) (values #,@(make-list (length (syntax->list #'(x ...))) #'#f)))
|
(define-values (tmp ...) (values #,@(make-list (length (syntax->list #'(x ...))) #'#f)))
|
||||||
(define action-id
|
(define action-id
|
||||||
(capture-actor-actions
|
(ensure-spawn-actions!
|
||||||
(lambda () (set!-values (tmp ...) e))))
|
(capture-actor-actions
|
||||||
|
(lambda () (set!-values (tmp ...) e)))))
|
||||||
(define-values (x ...) (values tmp ...))
|
(define-values (x ...) (values tmp ...))
|
||||||
(syndicate-module (action-ids ... action-id) (forms ...)))]
|
(syndicate-module (action-ids ... action-id) (forms ...)))]
|
||||||
[(head rest ...)
|
[(head rest ...)
|
||||||
|
@ -99,8 +108,9 @@
|
||||||
#`(begin #,expanded (syndicate-module (action-ids ...) (forms ...)))]
|
#`(begin #,expanded (syndicate-module (action-ids ...) (forms ...)))]
|
||||||
[else
|
[else
|
||||||
(with-syntax ([action-id (car (generate-temporaries (list #'form)))])
|
(with-syntax ([action-id (car (generate-temporaries (list #'form)))])
|
||||||
#`(begin (define action-id (capture-actor-actions (lambda () #,expanded)))
|
#`(begin
|
||||||
(syndicate-module (action-ids ... action-id) (forms ...))))])]
|
(define action-id (ensure-spawn-actions! (capture-actor-actions (lambda () #,expanded))))
|
||||||
|
(syndicate-module (action-ids ... action-id) (forms ...))))])]
|
||||||
[non-pair-syntax
|
[non-pair-syntax
|
||||||
#'(begin form (syndicate-module (action-ids ...) (forms ...)))])]
|
#'(begin form (syndicate-module (action-ids ...) (forms ...)))])]
|
||||||
[(_ (action-ids ...) ())
|
[(_ (action-ids ...) ())
|
||||||
|
|
|
@ -282,53 +282,86 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; JobManager
|
;; JobManager
|
||||||
|
|
||||||
|
;; assertions used for internal slot-management protocol
|
||||||
|
(assertion-struct slots (v))
|
||||||
|
(assertion-struct slot-assignment (who mngr))
|
||||||
|
;; tid is the TaskID, rid is a unique symbol to a particular request for a slot
|
||||||
|
(struct request-id (tid rid) #:prefab)
|
||||||
|
|
||||||
|
(message-struct task-is-ready (job-id task))
|
||||||
|
|
||||||
(define (spawn-job-manager)
|
(define (spawn-job-manager)
|
||||||
(spawn
|
(spawn
|
||||||
(assert (job-manager-alive))
|
(assert (job-manager-alive))
|
||||||
(log "Job Manager Up")
|
(log "Job Manager Up")
|
||||||
|
|
||||||
;; keep track of task managers, how many slots they say are open, and how many tasks we have assigned.
|
(on-start
|
||||||
(define/query-hash task-managers (task-manager $id $slots) id slots
|
(react
|
||||||
#:on-add (log "JM learns that ~a has ~v slots" id slots))
|
|
||||||
|
|
||||||
;; (Hashof TaskManagerID Nat)
|
;; keep track of task managers, how many slots they say are open, and how many tasks we have assigned.
|
||||||
;; to better understand the supply of slots for each task manager, keep track of the number
|
;; (Hashof TaskManagerID Nat)
|
||||||
;; of requested tasks that we have yet to hear back about
|
(define/query-hash task-managers (task-manager $id $slots) id slots
|
||||||
(field [requests-in-flight (hash)])
|
#:on-add (log "JM learns that ~a has ~v slots" id slots))
|
||||||
(define (slots-available)
|
|
||||||
(for/sum ([(id v) (in-hash (task-managers))])
|
(field [requests-in-flight (hash)] ;; (Hashof ID Nat)
|
||||||
(max 0 (- v (hash-ref (requests-in-flight) id 0)))))
|
[assignments (hash)]) ;; (Hashof ID ID) request ID to manager ID
|
||||||
;; ID -> Void
|
|
||||||
;; mark that we have requested the given task manager to perform a task
|
;; to better understand the supply of slots for each task manager, keep track of the number
|
||||||
(define (take-slot! id)
|
;; of requested tasks that we have yet to hear back about
|
||||||
(requests-in-flight (hash-update (requests-in-flight) id add1 0)))
|
(define (slots-available)
|
||||||
;; ID -> Void
|
(for/sum ([(id v) (in-hash (task-managers))])
|
||||||
;; mark that we have heard back from the given manager about a requested task
|
(max 0 (- v (hash-ref (requests-in-flight) id 0)))))
|
||||||
(define (received-answer! id)
|
|
||||||
(requests-in-flight (hash-update (requests-in-flight) id sub1)))
|
;; ID -> (U #f ID)
|
||||||
|
(define (try-take-slot! me)
|
||||||
|
(define mngr
|
||||||
|
(for/first ([(id slots) (in-hash (task-managers))]
|
||||||
|
#:when (positive? (- slots (hash-ref (requests-in-flight) id 0))))
|
||||||
|
id))
|
||||||
|
(when mngr
|
||||||
|
(assignments (hash-set (assignments) me mngr))
|
||||||
|
(requests-in-flight (hash-update (requests-in-flight) mngr add1 0)))
|
||||||
|
mngr)
|
||||||
|
|
||||||
|
(know (slots (slots-available)))
|
||||||
|
|
||||||
|
(during (know (observe (slot-assignment (request-id $tid $who) _)))
|
||||||
|
(on-start
|
||||||
|
(react
|
||||||
|
;; what if one manager gains a slot but another loses one, so n stays the same?
|
||||||
|
(on (know (slots $n))
|
||||||
|
#;(log "Dispatcher request ~a learns there are ~a slots" tid n)
|
||||||
|
(unless (or (zero? n) (hash-has-key? (assignments) who))
|
||||||
|
(define mngr (try-take-slot! who))
|
||||||
|
(when mngr
|
||||||
|
(stop-current-facet
|
||||||
|
(log "Dispatcher assigns task ~a to ~a" tid mngr)
|
||||||
|
(react (know (slot-assignment (request-id tid who) mngr)))
|
||||||
|
(react
|
||||||
|
(define waiting-for-answer (current-facet-id))
|
||||||
|
(on (asserted (observe (task-performance mngr (task tid $x) _)))
|
||||||
|
(react (on (asserted (task-performance mngr (task tid x) _))
|
||||||
|
(log "Dispatcher sees answer for ~a" tid)
|
||||||
|
(stop-facet waiting-for-answer))))
|
||||||
|
(on-stop
|
||||||
|
(requests-in-flight (hash-update (requests-in-flight) mngr sub1))))))))))
|
||||||
|
(on-stop (assignments (hash-remove (assignments) who))))))
|
||||||
|
|
||||||
(during (observe (job-completion $job-id $tasks _))
|
(during (observe (job-completion $job-id $tasks _))
|
||||||
(log "JM receives job ~a" job-id)
|
(log "JM receives job ~a" job-id)
|
||||||
(define-values (ready not-ready) (partition task-ready? tasks))
|
(define-values (ready not-ready) (partition task-ready? tasks))
|
||||||
(field [ready-tasks ready]
|
(field [waiting-tasks not-ready]
|
||||||
[waiting-tasks not-ready]
|
|
||||||
[tasks-in-progress 0])
|
[tasks-in-progress 0])
|
||||||
|
|
||||||
(begin/dataflow
|
(on-start (for [(t ready)] (add-ready-task! t)))
|
||||||
(define slots (slots-available))
|
(on (realize (task-is-ready job-id $t))
|
||||||
(define-values (ts readys)
|
|
||||||
(split-at/lenient (ready-tasks) slots))
|
|
||||||
(for ([t ts])
|
|
||||||
(perform-task t push-results))
|
(perform-task t push-results))
|
||||||
(unless (empty? ts)
|
|
||||||
;; the empty? check may be necessary to avoid a dataflow loop
|
|
||||||
(ready-tasks readys)))
|
|
||||||
|
|
||||||
;; Task -> Void
|
;; Task -> Void
|
||||||
(define (add-ready-task! t)
|
(define (add-ready-task! t)
|
||||||
;; TODO - use functional-queue.rkt from ../../
|
;; TODO - use functional-queue.rkt from ../../
|
||||||
(log "JM marks task ~a as ready" (task-id t))
|
(log "JM marks task ~a as ready" (task-id t))
|
||||||
(ready-tasks (cons t (ready-tasks))))
|
(realize! (task-is-ready job-id t)))
|
||||||
|
|
||||||
;; Task (ID TaskResult -> Void) -> Void
|
;; Task (ID TaskResult -> Void) -> Void
|
||||||
;; Requires (task-ready? t)
|
;; Requires (task-ready? t)
|
||||||
|
@ -340,35 +373,23 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(match-define (task this-id desc) t)
|
(match-define (task this-id desc) t)
|
||||||
(log "JM begins on task ~a" this-id)
|
(log "JM begins on task ~a" this-id)
|
||||||
|
|
||||||
|
|
||||||
(define (select-a-task-manager)
|
(define (select-a-task-manager)
|
||||||
(react
|
(react
|
||||||
(field [selection #f])
|
(define req-id (gensym 'perform-task))
|
||||||
(begin/dataflow
|
(on (know (slot-assignment (request-id this-id req-id) $mngr))
|
||||||
(unless (selection)
|
(assign-task mngr))))
|
||||||
(define mngr
|
|
||||||
(for/first ([(id slots) (in-hash (task-managers))]
|
|
||||||
#:when (positive? (- slots (hash-ref (requests-in-flight) id 0))))
|
|
||||||
id))
|
|
||||||
(when mngr
|
|
||||||
(selection mngr)
|
|
||||||
(take-slot! mngr)
|
|
||||||
(log "JM assigns task ~a to ~a" this-id mngr)
|
|
||||||
(stop-current-facet (assign-task mngr)))))))
|
|
||||||
|
|
||||||
;; ID -> ...
|
;; ID -> ...
|
||||||
(define (assign-task mngr)
|
(define (assign-task mngr)
|
||||||
|
(define this-facet (current-facet-id))
|
||||||
(react
|
(react
|
||||||
(define this-facet (current-facet-id))
|
#;(define this-facet (current-facet-id))
|
||||||
(on (retracted (task-manager mngr _))
|
(on (retracted (task-manager mngr _))
|
||||||
;; our task manager has crashed
|
;; our task manager has crashed
|
||||||
(stop-current-facet (select-a-task-manager)))
|
(stop-current-facet (select-a-task-manager)))
|
||||||
(on-start
|
(on-start
|
||||||
;; N.B. when this line was here, and not after `(when mngr ...)` above,
|
(log "JM assigns task ~a to manager ~a" this-id mngr)
|
||||||
;; things didn't work. I think that due to script scheduling, all ready
|
|
||||||
;; tasks were being assigned to the manager
|
|
||||||
#;(take-slot! mngr)
|
|
||||||
(react (stop-when (asserted (task-performance mngr t _))
|
|
||||||
(received-answer! mngr)))
|
|
||||||
(task-assigner t mngr
|
(task-assigner t mngr
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;; need to find a new task manager
|
;; need to find a new task manager
|
||||||
|
@ -387,8 +408,9 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
;; them to the ready queue when possible
|
;; them to the ready queue when possible
|
||||||
(define (push-results task-id data)
|
(define (push-results task-id data)
|
||||||
(cond
|
(cond
|
||||||
|
;; this is an interesting scenario wrt stop handlers running; this code is assuming
|
||||||
|
;; it runs after the on-stop above that decrements `tasks-in-progress`
|
||||||
[(and (zero? (tasks-in-progress))
|
[(and (zero? (tasks-in-progress))
|
||||||
(empty? (ready-tasks))
|
|
||||||
(empty? (waiting-tasks)))
|
(empty? (waiting-tasks)))
|
||||||
(log "JM finished with job ~a" job-id)
|
(log "JM finished with job ~a" job-id)
|
||||||
(react (assert (job-completion job-id tasks data)))]
|
(react (assert (job-completion job-id tasks data)))]
|
||||||
|
|
|
@ -60,7 +60,10 @@
|
||||||
(quit))]
|
(quit))]
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
|
|
||||||
(message (set-timer 'tick 1000 'relative))
|
(actor (lambda (e s) (quit))
|
||||||
|
#f
|
||||||
|
(message (set-timer 'tick 1000 'relative)))
|
||||||
|
|
||||||
(actor ticker
|
(actor ticker
|
||||||
1
|
1
|
||||||
(patch-seq (sub (observe (set-timer ? ? ?)))
|
(patch-seq (sub (observe (set-timer ? ? ?)))
|
||||||
|
|
|
@ -3,3 +3,11 @@
|
||||||
(define racket-launcher-names '("syndicate-broker" "syndicate-render-msd"))
|
(define racket-launcher-names '("syndicate-broker" "syndicate-render-msd"))
|
||||||
(define racket-launcher-libraries '("broker/server.rkt" "trace/render-msd.rkt"))
|
(define racket-launcher-libraries '("broker/server.rkt" "trace/render-msd.rkt"))
|
||||||
(define test-include-paths '("syndicate/tests"))
|
(define test-include-paths '("syndicate/tests"))
|
||||||
|
(define test-omit-paths
|
||||||
|
'(;; Sam: example-plain is interactive, I think
|
||||||
|
"examples/example-plain.rkt"
|
||||||
|
;; Sam: for whatever reason I get a failure to load libcrypto for f-to-c
|
||||||
|
"examples/actor/f-to-c.rkt"
|
||||||
|
;; Sam: this test displays to stderr which the package server does not like
|
||||||
|
"tests/nested-spawn-exceptions.rkt"
|
||||||
|
))
|
||||||
|
|
|
@ -13,6 +13,7 @@
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
(require rackunit)
|
(require rackunit)
|
||||||
(require racket/engine)
|
(require racket/engine)
|
||||||
|
(require racket/exn)
|
||||||
|
|
||||||
(define mt-scn (scn trie-empty))
|
(define mt-scn (scn trie-empty))
|
||||||
|
|
||||||
|
@ -289,7 +290,7 @@
|
||||||
;; leaf behavior function
|
;; leaf behavior function
|
||||||
(define (actor-behavior e s)
|
(define (actor-behavior e s)
|
||||||
(when e
|
(when e
|
||||||
(with-handlers ([exn:fail? (lambda (e) (eprintf "exception: ~v\n" e) (quit #:exception e (list)))])
|
(with-handlers ([exn:fail? (lambda (e) (printf "exception: ~v\n" (exn->string e)) (quit #:exception e (list)))])
|
||||||
(match-define (actor-state π-old fts) s)
|
(match-define (actor-state π-old fts) s)
|
||||||
(define-values (actions next-fts)
|
(define-values (actions next-fts)
|
||||||
(for/fold ([as '()]
|
(for/fold ([as '()]
|
||||||
|
@ -545,7 +546,7 @@
|
||||||
;; boot-actor : actor Γ -> Action
|
;; boot-actor : actor Γ -> Action
|
||||||
(define (boot-actor a Γ)
|
(define (boot-actor a Γ)
|
||||||
(with-handlers ([exn:fail? (lambda (e)
|
(with-handlers ([exn:fail? (lambda (e)
|
||||||
(eprintf "booting actor died with: ~v\n" e)
|
(printf "booting actor died with: ~a\n" (exn->string e))
|
||||||
#f)])
|
#f)])
|
||||||
(match a
|
(match a
|
||||||
[`(spawn ,O ...)
|
[`(spawn ,O ...)
|
||||||
|
|
|
@ -28,7 +28,7 @@
|
||||||
#:macro-definer-name define-assertion-expander
|
#:macro-definer-name define-assertion-expander
|
||||||
#:introducer-parameter-name current-assertion-expander-introducer
|
#:introducer-parameter-name current-assertion-expander-introducer
|
||||||
#:local-introduce-name syntax-local-assertion-expander-introduce
|
#:local-introduce-name syntax-local-assertion-expander-introduce
|
||||||
#:expander-id-predicate-name assertion-expander-id?
|
#:expander-form-predicate-name assertion-expander-form?
|
||||||
#:expander-transform-name assertion-expander-transform)
|
#:expander-transform-name assertion-expander-transform)
|
||||||
|
|
||||||
(provide (for-syntax
|
(provide (for-syntax
|
||||||
|
@ -36,7 +36,7 @@
|
||||||
assertion-expander?
|
assertion-expander?
|
||||||
assertion-expander-proc
|
assertion-expander-proc
|
||||||
syntax-local-assertion-expander-introduce
|
syntax-local-assertion-expander-introduce
|
||||||
assertion-expander-id?
|
assertion-expander-form?
|
||||||
assertion-expander-transform)
|
assertion-expander-transform)
|
||||||
define-assertion-expander)
|
define-assertion-expander)
|
||||||
|
|
||||||
|
@ -153,8 +153,8 @@
|
||||||
bs
|
bs
|
||||||
ins))]
|
ins))]
|
||||||
|
|
||||||
[(expander args ...)
|
[expander
|
||||||
(assertion-expander-id? #'expander)
|
(assertion-expander-form? #'expander)
|
||||||
(assertion-expander-transform pat-stx (lambda (r) (walk (syntax-rearm r pat-stx))))]
|
(assertion-expander-transform pat-stx (lambda (r) (walk (syntax-rearm r pat-stx))))]
|
||||||
|
|
||||||
[(ctor p ...)
|
[(ctor p ...)
|
||||||
|
|
|
@ -3,27 +3,578 @@
|
||||||
@(require (for-label (except-in racket process field)
|
@(require (for-label (except-in racket process field)
|
||||||
syndicate/actor))
|
syndicate/actor))
|
||||||
|
|
||||||
@title{High Level Syntax for Syndicate}
|
@title{Dataspace Programming with Syndicate}
|
||||||
|
|
||||||
|
|
||||||
@defmodule[syndicate/actor]
|
@defmodule[syndicate/actor]
|
||||||
|
|
||||||
@section{Instantaneous Actions (I)}
|
@section{Overview}
|
||||||
|
|
||||||
@defform[(spawn I ...)]{
|
Syndicate is an actor language where all communication occurs through a tightly
|
||||||
Spawns an actor that executes each instantaneous action @racket[I] in
|
controlled shared memory, dubbed the @emph{dataspace}. The values in the
|
||||||
sequence.}
|
dataspace are called @emph{assertions}, representing the information that the
|
||||||
|
actors in the system are currently sharing with each other. Assertions are
|
||||||
|
@emph{read-only} and @emph{owned} by the actor that entered them into the
|
||||||
|
dataspace. Only the originating actor has permission to withdraw an assertion.
|
||||||
|
Assertions are linked to the lifetime of their actor, and are withdrawn from the
|
||||||
|
dataspace when that actor exits, either normally or via exception.
|
||||||
|
|
||||||
@defform[(dataspace I ...)]{
|
To respond to assertions in the dataspace, an actor expresses an @emph{interest}
|
||||||
Spawns a dataspace as a child of the dataspace enclosing the executing actor. The
|
in the shape of assertions it wishes to receive. An interest is an assertion
|
||||||
new dataspace executes each instantaneous action @racket[I].}
|
constructed with @racket[observe] and wildcards where the actor wishes to
|
||||||
|
receive any matching assertion. When an actor makes an assertion of interest,
|
||||||
|
the dataspace dispatches the set of all matching assertions to that actor.
|
||||||
|
Moreover, the dataspace keeps the actor @emph{up-to-date}, informing it when a
|
||||||
|
new assertion appears matching its interest, as well as when a matching
|
||||||
|
assertion disappears from the dataspace. Thus, dataspaces implement a form of
|
||||||
|
publish/subscribe communication.
|
||||||
|
|
||||||
@defproc[(send! [v any/c]
|
@;{would be nice to link pub/sub}
|
||||||
[#:meta-level level natural-number/c 0])
|
|
||||||
|
In addition to assertions, dataspaces support instantaneous @racket[message]
|
||||||
|
broadcast. At the time a message is sent, all actors with a matching interest
|
||||||
|
receive notification.
|
||||||
|
|
||||||
|
In response to an event, that is, a message broadcast or assertion
|
||||||
|
appearance/disappearance matching an expressed interest, a Syndicate actor may
|
||||||
|
take any of the following actions:
|
||||||
|
@itemlist[
|
||||||
|
@item{Updating its internal state;}
|
||||||
|
@item{Making or withdrawing assertions;}
|
||||||
|
@item{Sending broadcast messages;}
|
||||||
|
@item{Spawning additional actors;}
|
||||||
|
@item{Exiting;}
|
||||||
|
@item{Or any combination of these.}
|
||||||
|
]
|
||||||
|
|
||||||
|
Thus, each individual Syndicate actor has three fudamental concerns:
|
||||||
|
|
||||||
|
@itemlist[
|
||||||
|
@item{Defining local state and updating it in response to events;}
|
||||||
|
@item{Publishing aspects of local state/knowledge as assertions; and}
|
||||||
|
@item{Reacting to relevant assertions and messages.}
|
||||||
|
]
|
||||||
|
|
||||||
|
Each concern is addressed by a separate language construct, which are
|
||||||
|
collectively dubbed @emph{endpoints}:
|
||||||
|
|
||||||
|
@itemlist[
|
||||||
|
@item{The @racket[field]s of an actor hold its state;}
|
||||||
|
@item{An actor publishes information using @racket[assert]; and}
|
||||||
|
@item{An event-handler endpoint uses @racket[on] to define reactions to
|
||||||
|
particular messages and assertions.}
|
||||||
|
]
|
||||||
|
|
||||||
|
Endpoints are tied together via @emph{dataflow}. Thus, the assertions of an
|
||||||
|
actor automatically reflect the current value of its fields.
|
||||||
|
|
||||||
|
Implementing an actor's role in a particular conversation typically involves
|
||||||
|
some combination of these behaviors; a @emph{facet} is a collection of related
|
||||||
|
endpoints constituting the actor's participation in a particular conversation.
|
||||||
|
|
||||||
|
Each actor starts with a single facet, and may add new facets or terminate
|
||||||
|
current ones in response to events. The facets of an actor form a tree, where
|
||||||
|
the parent of a particular facet is the facet in which it was created. The tree
|
||||||
|
structure affects facet shutdown; terminating a facet also terminates all of its
|
||||||
|
descendants.
|
||||||
|
|
||||||
|
To recap: an actor is a tree of facets, each of which comprises of a collection
|
||||||
|
of endpoints.
|
||||||
|
|
||||||
|
@section{Programming Syndicate Actors with Facets}
|
||||||
|
|
||||||
|
Code within Syndicate actors executes in one of two contexts:
|
||||||
|
@itemlist[
|
||||||
|
@item{The @emph{endpoint-installation} context occurs during the creation of a
|
||||||
|
new facet, when all of its endpoints are created.}
|
||||||
|
@item{The @emph{script} context occurs during the execution of event handlers,
|
||||||
|
and permits creating/terminating facets, sending messages, and spawning
|
||||||
|
actors.}
|
||||||
|
]
|
||||||
|
|
||||||
|
The actions permitted by the two contexts are mutually exclusive, and trying to
|
||||||
|
perform an action in the wrong context will give rise to a run-time
|
||||||
|
@racket[error].
|
||||||
|
|
||||||
|
Within the following descriptions, we use @emph{EI} as a shorthand for
|
||||||
|
expressions that execute in an endpoint-installation context and @emph{S} for
|
||||||
|
expressions in a script context.
|
||||||
|
|
||||||
|
@subsection{Script Actions: Starting and Stopping Actors and Facets}
|
||||||
|
|
||||||
|
@defform[(spawn maybe-name
|
||||||
|
maybe-assertions
|
||||||
|
maybe-linkage
|
||||||
|
EI ...+)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-name (code:line)
|
||||||
|
(code:line #:name name-expr))
|
||||||
|
(maybe-assertions (code:line)
|
||||||
|
(code:line #:assertions assertion-expr)
|
||||||
|
(code:line #:assertions* assertions-expr))
|
||||||
|
(maybe-linkage (code:line)
|
||||||
|
(code:line #:linkage [linkage-expr ...]))]
|
||||||
|
#:contracts
|
||||||
|
([assertion-expr any/c]
|
||||||
|
[assertions-expr trie?])]{
|
||||||
|
Spawn an actor with a single inital facet whose endpoints are installed by
|
||||||
|
@racket[EI]. That is, there is an implicit @racket[react] around @racket[EI
|
||||||
|
...]. Allowed within a script and module-top-level.
|
||||||
|
|
||||||
|
An optionally provided @racket[name-expr] is associated with the created actor.
|
||||||
|
The name is only used for error and log messages, thus is mainly useful for
|
||||||
|
debugging.
|
||||||
|
|
||||||
|
The actor may optionally be given some initial assertions, which come into being
|
||||||
|
at the same time as the actor. (Otherwise, the actor spawns, then boots its
|
||||||
|
initial facet(s), then establishes any ensuing assertions.) When
|
||||||
|
@racket[assertion-expr] is provided, the actors initial assertions are the
|
||||||
|
result of interpreting the expression as a @racket[trie] pattern, with
|
||||||
|
@racket[?] giving rise to infinte sets. On the other hand,
|
||||||
|
@racket[assertions-expr] may be used to specify an entire set of initial
|
||||||
|
assertions as an arbitrary @racket[trie].
|
||||||
|
|
||||||
|
The optional @racket[linkage-expr]s are executed during facet startup; your
|
||||||
|
simple documentation author is not sure why they are useful, as opposed to just
|
||||||
|
putting them in the body of the @racket[spawn].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(react EI ...+)]{
|
||||||
|
Create a new facet in the current actor whose endpoints are the result of
|
||||||
|
executing @racket[EI ...]. Allowed within a script.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(stop-facet fid S ...)
|
||||||
|
#:contracts ([fid facet-id?])]{
|
||||||
|
Terminate the facet with ID @racket[fid], as well as all of its children.
|
||||||
|
Allowed within a script.
|
||||||
|
|
||||||
|
The optional script actions @racket[S ...] function like a continuation. They
|
||||||
|
run @emph{after} the facet and all of its children finish shutting down, i.e.
|
||||||
|
after all @racket[stop] handlers have executed. Moreover, @racket[S ...] runs in
|
||||||
|
the context of the @emph{parent} of @racket[fid]. Thus, any facet created by the
|
||||||
|
script survives termination and will have @racket[fid]'s parent as its own
|
||||||
|
parent.
|
||||||
|
|
||||||
|
Note that @racket[fid] must be an ancestor of the current facet.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(stop-current-facet S ...)]{
|
||||||
|
Stop the currently running facet; equivalent to
|
||||||
|
@racketblock[(stop-facet (current-facet-id) S ...)].
|
||||||
|
|
||||||
|
Allowed within a script.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(current-facet-id) facet-id?]{
|
||||||
|
Retrieves the ID of the currently running facet.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(send! [v any/c])
|
||||||
void?]{
|
void?]{
|
||||||
Sends a message with body @racket[v]. The message is sent @racket[level]
|
Sends a @racket[message] with body @racket[v].
|
||||||
dataspaces removed from the dataspace containing the actor performing the
|
|
||||||
@racket[send!].}
|
Allowed within a script.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Installing Endpoints}
|
||||||
|
|
||||||
|
@defform[(field [x init-expr maybe-contract] ...+)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-contract (code:line)
|
||||||
|
(code:line #:contract in)
|
||||||
|
(code:line #:contract in out))]]{
|
||||||
|
Define fields for the current facet. Each @racket[x] is bound to a handle
|
||||||
|
function: calling @racket[(x)] retrieves the current value, while @racket[(x v)]
|
||||||
|
sets the field to @racket[v].
|
||||||
|
|
||||||
|
Fields may optionally have a contract; the @racket[in] contract is applied when
|
||||||
|
writing to a field, while the (optional) @racket[out] contract applies when
|
||||||
|
reading a value from a field.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(assert maybe-pred exp)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-pred (code:line)
|
||||||
|
(code:line #:when pred))]
|
||||||
|
#:contracts ([pred boolean?])]{
|
||||||
|
Make the assertion @racket[exp] while the enclosing facet is active. Publishing
|
||||||
|
the assertion can be made conditional on a boolean expression by supplying a
|
||||||
|
@racket[#:when] predicate, in which case the assertion is made only when
|
||||||
|
@racket[pred] evaluates to a truthy value.
|
||||||
|
|
||||||
|
If the expression @racket[exp] refers to any fields, then the assertion created
|
||||||
|
by the endpoint is automatically kept up-to-date each time any of those fields
|
||||||
|
is updated. More specifically, the will issue a patch retracting the assertion
|
||||||
|
of the previous value, replacing it with the results of reevaluating
|
||||||
|
@racket[exp] with the current values of each field.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (message asserted retracted _ $ ?)
|
||||||
|
(on maybe-pred event-description
|
||||||
|
S ...+)
|
||||||
|
|
||||||
|
#:grammar
|
||||||
|
[(maybe-pred (code:line)
|
||||||
|
(code:line #:when pred))
|
||||||
|
(event-description (code:line (message pattern))
|
||||||
|
(code:line (asserted pattern))
|
||||||
|
(code:line (retracted pattern)))
|
||||||
|
(pattern (code:line _)
|
||||||
|
(code:line $id)
|
||||||
|
(code:line ($ id pattern))
|
||||||
|
(code:line (? pred pattern))
|
||||||
|
(code:line (ctor pattern ...))
|
||||||
|
(code:line expr))]
|
||||||
|
#:contracts ([pred boolean?])]{
|
||||||
|
Creates an event handler endpoint that responds to the event specified by
|
||||||
|
@racket[event-description]. Executes the body @racket[S ...] for each matching
|
||||||
|
event, with any pattern variables bound to their matched value.
|
||||||
|
|
||||||
|
The actor will make an assertion of interest in events that could match
|
||||||
|
@racket[event-description]. Like with @racket[assert], the interest will be
|
||||||
|
refreshed any time a field referenced within the @racket[event-description]
|
||||||
|
pattern changes.
|
||||||
|
|
||||||
|
The event handler can optionally be made conditional on a boolean expression by
|
||||||
|
supplying a @racket[#:when] predicate, in which case the endpoint only reacts to
|
||||||
|
events, and only expresses the corresponding assertion of interest, when
|
||||||
|
@racket[pred] evaluates to a truthy value.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
|
||||||
|
Event descriptions have one of the following forms:
|
||||||
|
@itemlist[
|
||||||
|
@item{@racket[(message pattern)] activates when a message is received with a
|
||||||
|
body matching @racket[pat].}
|
||||||
|
|
||||||
|
@item{@racket[(asserted pattern)] activates when a patch is received with an
|
||||||
|
added assertion matching @racket[pattern]. Additionally, if the actor has
|
||||||
|
@emph{already} received a patch with matching assertions, which can occur if
|
||||||
|
multiple facets in a single actor have overlapping interests, then the
|
||||||
|
endpoint will match those assertions upon facet start up.}
|
||||||
|
|
||||||
|
@item{@racket[(retracted pat)] is similar to @racket[asserted], but for
|
||||||
|
assertions withdrawn in a patch.}
|
||||||
|
|
||||||
|
@;{@item{@racket[(rising-edge expr)] activates when @racket[expr] evaluates to
|
||||||
|
anything besides @racket[#f] (having previously evaluated to @racket[#f]). The
|
||||||
|
condition is checked after each received event.}}
|
||||||
|
]
|
||||||
|
|
||||||
|
While patterns have the following meanings:
|
||||||
|
@itemlist[
|
||||||
|
@item{@racket[_] matches anything.}
|
||||||
|
|
||||||
|
@item{@racket[$id] matches anything and binds the value to @racket[id].}
|
||||||
|
|
||||||
|
@item{@racket[($ id pattern)] matches values that match @racket[pattern] and
|
||||||
|
binds the value to @racket[id].}
|
||||||
|
|
||||||
|
@item{@racket[(? pred pattern)] matches values where @racket[(pred val)] is not
|
||||||
|
@racket[#f] and that match @racket[pattern].}
|
||||||
|
|
||||||
|
@item{@racket[(ctor pat ...)] matches values built by applying the constructor
|
||||||
|
@racket[ctor] to values matching @racket[pat ...]. @racket[ctor] is usually
|
||||||
|
a @racket[struct] name.}
|
||||||
|
|
||||||
|
@item{@racket[expr] patterns match values that are @racket[equal?] to
|
||||||
|
@racket[expr].}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(during pattern EI ...+)]{
|
||||||
|
Engage in behavior for the duration of a matching assertion. Roughly equivalent
|
||||||
|
to:
|
||||||
|
|
||||||
|
@racketblock[
|
||||||
|
(on (asserted pattern)
|
||||||
|
(react
|
||||||
|
EI ...
|
||||||
|
(on (retracted inst-pattern)
|
||||||
|
(stop-current-facet))))]
|
||||||
|
|
||||||
|
where @racket[inst-pattern] is the @racket[pattern] with variables instantiated
|
||||||
|
to their matching values.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(during/spawn pattern
|
||||||
|
maybe-actor-wrapper
|
||||||
|
maybe-name
|
||||||
|
maybe-assertions
|
||||||
|
maybe-parent-let
|
||||||
|
maybe-on-crash
|
||||||
|
EI ...)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-actor-wrapper (code:line)
|
||||||
|
(code:line #:spawn wrapper-stx))
|
||||||
|
(maybe-parent-let (code:line)
|
||||||
|
(code:line #:let [x expr] ...))
|
||||||
|
(maybe-on-crash (code:line)
|
||||||
|
(code:line #:on-crash on-crash-expr))]]{
|
||||||
|
Like @racket[during], but in addition to creating a new facet for each matching
|
||||||
|
assertion, @racket[spawn]s a new actor. The difference is primarily relevant for
|
||||||
|
error propagation; an exception inside @racket[during] causes the entire actor
|
||||||
|
to crash, while an exception inside @racket[during/spawn] crashes only the newly
|
||||||
|
spawned actor.
|
||||||
|
|
||||||
|
The assertion triggering the @racket[during/spawn] may disappear @emph{before}
|
||||||
|
the spawned actor boots, in which case it fails to see the retraction event. To
|
||||||
|
avoid potential glitches, the @emph{spawning} actor maintains an assertion that
|
||||||
|
lets the @racket[spawned] actor know whether the originial assertion still
|
||||||
|
exists.
|
||||||
|
|
||||||
|
The @racket[maybe-name] and @racket[maybe-assertions] have the same meaning they
|
||||||
|
do for @racket[spawn], applied to the newly spawned actor.
|
||||||
|
|
||||||
|
The @racket[wrapper-stx] serves as an interposition point; it may be provided to
|
||||||
|
change the meaning of "spawning an actor" in response to an assertion. By
|
||||||
|
default, it is @racket[#'spawn].
|
||||||
|
|
||||||
|
The optional @racket[#:let] clauses can be used to read the values of fields in
|
||||||
|
the @emph{spawning} actor so that they can be used in the @emph{spawned} actor.
|
||||||
|
Otherwise, the spawned actor has no access to the parent's fields, and trying to
|
||||||
|
read or write to such a field will cause a runtime @racket[error].
|
||||||
|
|
||||||
|
The @racket[on-crash-expr] provides a hook for script actions that can be
|
||||||
|
performed in the @emph{spawning} actor if the @emph{spawned} actor crashes.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(stop-when maybe-pred event-description S ...)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-pred (code:line)
|
||||||
|
(code:line #:when pred))]
|
||||||
|
#:contracts ([pred boolean?])]{
|
||||||
|
Stop the current facet when an event matching @racket[event-description] occurs.
|
||||||
|
Roughly equivalent to
|
||||||
|
@racketblock[
|
||||||
|
(on event-description
|
||||||
|
(stop-current-facet S ...))]
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Handling Facet Startup and Shutdown}
|
||||||
|
|
||||||
|
In addition to external events, such as assertion (dis)appearance and message
|
||||||
|
broadcast, facets can react to their own startup and shutdown. This provides a
|
||||||
|
handy way to perform initialization, cleanup, as well as setting up and tearing
|
||||||
|
down resources.
|
||||||
|
|
||||||
|
@defform[(on-start S ...)]{
|
||||||
|
Perform the script actions @racket[S ...] upon facet startup.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(on-stop S ...)]{
|
||||||
|
Perform the script actions @racket[S ...] upon facet shutdown.
|
||||||
|
|
||||||
|
The script @racket[S ...] differs from that of @racket[stop-facet] in that it
|
||||||
|
executes in the context of the terminating facet, not its parent. Thus, any
|
||||||
|
facets created in @racket[S ...] will start up and then immediately shut down.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
Note that a single facet may have any number of @racket[on-start] and
|
||||||
|
@racket[on-stop] handlers, which do not compete with each other. That is, each
|
||||||
|
@racket[on-start] handler runs during facet startup and, likewise, each
|
||||||
|
@racket[on-stop] during facet shutdown.
|
||||||
|
|
||||||
|
@subsection{Streaming Query Fields}
|
||||||
|
|
||||||
|
Syndicate actors often aggregate information about current assertions as part of
|
||||||
|
their local state, that is, in a @racket[field]. Since these patterns are
|
||||||
|
exceedingly common, Syndicate provides a number of forms for defining fields
|
||||||
|
that behave as streaming queries over the assertions in the dataspace.
|
||||||
|
|
||||||
|
@defform[(define/query-set name pattern expr maybe-on-add maybe-on-remove)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-on-add (code:line)
|
||||||
|
(code:line #:on-add on-add-expr))
|
||||||
|
(maybe-on-remove (code:line)
|
||||||
|
(code:line #:on-remove on-remove-expr))]]{
|
||||||
|
Define a @racket[field] called @racket[name] that is the @racket[set] of values
|
||||||
|
extracted from assertions matching @racket[pattern]. Each value is extracted
|
||||||
|
from a matching assertion by evaluating @racket[expr], which may refer to
|
||||||
|
variables bound by @racket[pattern].
|
||||||
|
|
||||||
|
The query set expands to roughly the following code:
|
||||||
|
@racketblock[
|
||||||
|
(begin
|
||||||
|
(field [name (set)])
|
||||||
|
(on (asserted pattern)
|
||||||
|
(name (set-add (name) expr)))
|
||||||
|
(on (retracted pattern)
|
||||||
|
(name (set-remove (name) expr))))]
|
||||||
|
|
||||||
|
The optional @racket[on-add-expr] is performed inside the @racket[on asserted]
|
||||||
|
handler, while @racket[on-remove-expr] runs in the @racket[on retracted]
|
||||||
|
handler.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/query-hash name pattern key-expr value-expr
|
||||||
|
maybe-on-add
|
||||||
|
maybe-on-remove)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-on-add (code:line)
|
||||||
|
(code:line #:on-add on-add-expr))
|
||||||
|
(maybe-on-remove (code:line)
|
||||||
|
(code:line #:on-remove on-remove-expr))]]{
|
||||||
|
Define a @racket[field] called @racket[name] that is a @racket[hash] based on
|
||||||
|
assertions matching @racket[pattern]. Each matching assertion establishes a key
|
||||||
|
in the hash based on @racket[key-expr] whose value is the result of
|
||||||
|
@racket[value-expr], with each expression referring to variables bound by
|
||||||
|
@racket[pattern]. When a matching assertion disappears from the dataspace, the
|
||||||
|
associated key is removed from the hash.
|
||||||
|
|
||||||
|
The optional @racket[maybe-on-add] and @racket[maybe-on-expr] behave the same
|
||||||
|
way they do for @racket[define/query-set].
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/query-value name absent-expr pattern expr
|
||||||
|
maybe-on-add
|
||||||
|
maybe-on-remove)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-on-add (code:line)
|
||||||
|
(code:line #:on-add on-add-expr))
|
||||||
|
(maybe-on-remove (code:line)
|
||||||
|
(code:line #:on-remove on-remove-expr))]]{
|
||||||
|
Define a @racket[field] called @racket[name] whose value is based on the
|
||||||
|
presence of an assertion matching @racket[pattern] in the dataspace. When such
|
||||||
|
an assertion is present, the value of the @racket[name] field is the result of
|
||||||
|
evaluating @racket[expr], which may refer to @racket[pattern]. When no such
|
||||||
|
assertion exists, including initially, the value of @racket[name] is the result
|
||||||
|
of @racket[absent-expr].
|
||||||
|
|
||||||
|
The optional @racket[maybe-on-add] and @racket[maybe-on-expr] behave the same
|
||||||
|
way they do for @racket[define/query-set].
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/query-count name pattern key-expr
|
||||||
|
maybe-on-add
|
||||||
|
maybe-on-remove)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-on-add (code:line)
|
||||||
|
(code:line #:on-add on-add-expr))
|
||||||
|
(maybe-on-remove (code:line)
|
||||||
|
(code:line #:on-remove on-remove-expr))]]{
|
||||||
|
Define a @racket[field] called @racket[name] whose value is a @racket[hash]
|
||||||
|
counting occurrences of matching assertions in the dataspace. More precisely,
|
||||||
|
for each assertion @racket[pattern], evaluating @racket[key-expr] determines a
|
||||||
|
key in the hash; the value for that key is incremented when the assertion
|
||||||
|
appears and decremented when it disappears. When the count associated with a
|
||||||
|
particular key falls to @racket[0], that key is removed from the hash.
|
||||||
|
|
||||||
|
The optional @racket[maybe-on-add] and @racket[maybe-on-expr] behave the same
|
||||||
|
way they do for @racket[define/query-set].
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Generalizing Dataflow}
|
||||||
|
|
||||||
|
The dataflow mechanism that automatically refreshes @racket[assert] endpoints
|
||||||
|
when a referenced field changes may be used to react to local state updates in
|
||||||
|
arbitrary ways using @racket[begin/dataflow].
|
||||||
|
|
||||||
|
@defform[(begin/dataflow S ...+)]{
|
||||||
|
Evaluate and perform the script actions @racket[S ...] during facet startup, and
|
||||||
|
then again each time a field referenced by the script updates.
|
||||||
|
|
||||||
|
Conceptually, @racket[begin/dataflow] may be thought of as an event handler
|
||||||
|
endpoint in the vein of @racket[on], where the event of interest is @emph{update
|
||||||
|
of local state}.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/dataflow name expr maybe-default)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-default (code:line)
|
||||||
|
(code:line #:default default-expr))]]{
|
||||||
|
Define a @racket[field] named @racket[name], whose value is reevaluated to the
|
||||||
|
result of @racket[expr] each time any referenced field changes.
|
||||||
|
|
||||||
|
The value of @racket[name] is either @racket[#f] or, if provided,
|
||||||
|
@racket[default-expr]. This initial value is observable for a short time during
|
||||||
|
facet startup.
|
||||||
|
|
||||||
|
Note that when a field referenced by @racket[expr] changes, there may be some
|
||||||
|
time before @racket[name] refreshes, during which "stale" values may be read
|
||||||
|
from the field.
|
||||||
|
|
||||||
|
Allowed within an endpoint installation context.
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@subsection{Generalizing Actor-Internal Communication}
|
||||||
|
|
||||||
|
Talk about internal assertions and messages.
|
||||||
|
|
||||||
|
@subsection{Nesting Dataspaces}
|
||||||
|
|
||||||
|
Nested dataspaces, inbound and outbound assertions, quit-datapace.
|
||||||
|
|
||||||
|
@defform[(dataspace S ...)]{
|
||||||
|
Spawns a dataspace as a child of the dataspace enclosing the executing actor.
|
||||||
|
The new dataspace executes each action @racket[S].
|
||||||
|
|
||||||
|
Allowed within a script.
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@section{@hash-lang[] @racket[syndicate] Programs}
|
||||||
|
|
||||||
|
In a @hash-lang[] @racket[syndicate] program, the results of top-level
|
||||||
|
expressions define the initial group of actors in the dataspace. That is,
|
||||||
|
evaluating @racket[spawn] or @racket[dataspace] in the context of the module
|
||||||
|
top-level adds that actor specification to the initial dataspace of the program.
|
||||||
|
For example, a module such as:
|
||||||
|
|
||||||
|
@codeblock[#:line-numbers 0]|{
|
||||||
|
#lang syndicate
|
||||||
|
|
||||||
|
(define (spawn-fun)
|
||||||
|
(spawn ...))
|
||||||
|
|
||||||
|
(spawn ...)
|
||||||
|
|
||||||
|
(spawn-fun)
|
||||||
|
}|
|
||||||
|
|
||||||
|
launches a syndicate program with two initial actors, one the result of the
|
||||||
|
@racket[spawn] expression on line 5 and one the result of evaluating the
|
||||||
|
@racket[spawn] expresion on line 3 during the course of calling
|
||||||
|
@racket[spawn-fun] on line 7.
|
||||||
|
|
||||||
|
The initial dataspace is referred to as the @emph{ground} dataspace, and it
|
||||||
|
plays a special role in Syndicate programming; see below.
|
||||||
|
|
||||||
|
@section{Interacting with the Outside World}
|
||||||
|
|
||||||
|
ground dataspace, drivers, etc.
|
||||||
|
|
||||||
|
@section{Actors with an Agenda}
|
||||||
|
|
||||||
|
Here we talk about @racket[spawn*] and @racket[react/suspend].
|
||||||
|
|
||||||
|
@section{Odds and Ends}
|
||||||
|
|
||||||
@defproc[(assert! [v any/c]
|
@defproc[(assert! [v any/c]
|
||||||
[#:meta-level level natural-number/c 0])
|
[#:meta-level level natural-number/c 0])
|
||||||
|
@ -39,8 +590,6 @@ distance from the dataspace containing the enclosing actor.}
|
||||||
Retracts any assertions made by the immediately enclosing actor at
|
Retracts any assertions made by the immediately enclosing actor at
|
||||||
@racket[level] dataspaces above the enclosing dataspace of the form @racket[v].}
|
@racket[level] dataspaces above the enclosing dataspace of the form @racket[v].}
|
||||||
|
|
||||||
@section{Ongoing Behaviors (O)}
|
|
||||||
|
|
||||||
@defform[(state maybe-init (maybe-bindings O ...) ([E I ...] ...))
|
@defform[(state maybe-init (maybe-bindings O ...) ([E I ...] ...))
|
||||||
#:grammar
|
#:grammar
|
||||||
[(maybe-init (code:line)
|
[(maybe-init (code:line)
|
||||||
|
@ -102,79 +651,3 @@ termination event but before the @racket[until] actor exits.}
|
||||||
#:contracts ([id identifier?])]{
|
#:contracts ([id identifier?])]{
|
||||||
The @racket[forever] behavior is analogous to a @racket[state] form with no
|
The @racket[forever] behavior is analogous to a @racket[state] form with no
|
||||||
termination events.}
|
termination events.}
|
||||||
|
|
||||||
@defform[(during pat O ...)]{
|
|
||||||
Runs the behaviors @racket[O ...] for the duration of each assertion matching
|
|
||||||
@racket[pat].
|
|
||||||
|
|
||||||
Roughly equivalent to
|
|
||||||
@racket[(on (asserted pat)
|
|
||||||
(until (retracted pat)
|
|
||||||
O ...))]
|
|
||||||
where the @racket[pat] in the @racket[until] clause is specialized to the actual
|
|
||||||
value matched by @racket[pat] in the @racket[asserted] clause.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defform[(assert maybe-pred exp maybe-level)
|
|
||||||
#:grammar
|
|
||||||
[(maybe-pred (code:line)
|
|
||||||
(code:line #:when pred))
|
|
||||||
(maybe-level (code:line)
|
|
||||||
(code:line #:meta-level level))]
|
|
||||||
#:contracts ([pred boolean?]
|
|
||||||
[level natural-number/c])]{
|
|
||||||
Makes the assertion @racket[exp] while the enclosing actor is running. If a
|
|
||||||
@racket[#:when] predicate is given, the assertion is made conditionally on the
|
|
||||||
predicate expression evaluating to true.}
|
|
||||||
|
|
||||||
@defform[(on E
|
|
||||||
I ...)]{
|
|
||||||
When the event @racket[E] becomes active, executes the instantaneous actions
|
|
||||||
@racket[I ...] in the body. The result of the final action is the result of the
|
|
||||||
entire behavior.}
|
|
||||||
|
|
||||||
@section{Events (E)}
|
|
||||||
|
|
||||||
@defform[(message pat)]{
|
|
||||||
Activates when a message is received with a body matching @racket[pat].
|
|
||||||
The message event establishes the enclosing actor's interest in @racket[pat].}
|
|
||||||
|
|
||||||
@defform[(asserted pat)]{
|
|
||||||
Activates when a patch is received with an added assertion matching
|
|
||||||
@racket[pat]. Establishes the enclosing actor's interest in @racket[pat].}
|
|
||||||
|
|
||||||
@defform[(retracted pat)]{
|
|
||||||
Similar to @racket[asserted], except for assertions removed in a patch.}
|
|
||||||
|
|
||||||
@defform[(rising-edge expr)]{
|
|
||||||
Activates when @racket[expr] evaluates to anything besides @racket[#f] (having
|
|
||||||
previously evaluated to @racket[#f]). The condition is checked after each
|
|
||||||
received event, corresponding to after each instantaneous action is executed.}
|
|
||||||
|
|
||||||
@section{Patterns}
|
|
||||||
|
|
||||||
@(racketgrammar
|
|
||||||
pat
|
|
||||||
(code:line)
|
|
||||||
(code:line _)
|
|
||||||
(code:line $id)
|
|
||||||
(code:line ($ id pat))
|
|
||||||
(code:line (? pred pat))
|
|
||||||
(code:line (ctor pat ...))
|
|
||||||
(code:line expr))
|
|
||||||
|
|
||||||
@racket[_] matches anything.
|
|
||||||
|
|
||||||
@racket[$id] matches anything and binds the value to @racket[id].
|
|
||||||
|
|
||||||
@racket[($ id pat)] matches values that match @racket[pat] and binds the value
|
|
||||||
to @racket[id].
|
|
||||||
|
|
||||||
@racket[(? pred pat)] matches values where @racket[(pred val)] is not
|
|
||||||
@racket[#f] and that match @racket[pat].
|
|
||||||
|
|
||||||
@racket[(ctor pat ...)] matches values built by applying the constructor
|
|
||||||
@racket[ctor] to values matching @racket[pat ...].
|
|
||||||
|
|
||||||
@racket[expr] patterns match values that are exactly equal to @racket[expr].
|
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
#lang syndicate/test
|
#lang syndicate/test
|
||||||
|
|
||||||
;; Reflects the current behavior of the little implementation,
|
;; The facet in the on-stop should immediately die and its assertion should never be visible.
|
||||||
;; but quite possibly *not* what should happen
|
;; Pretty sure the little implementation gets that wrong.
|
||||||
|
;; the trace does not have a way of saying there should never be a "here" assertion
|
||||||
|
|
||||||
(spawn
|
(spawn
|
||||||
(on-stop (react (assert (outbound "here"))))
|
(on-stop (react (assert (outbound "here"))))
|
||||||
|
@ -9,4 +10,4 @@
|
||||||
|
|
||||||
(spawn (on-start (send! "stop")))
|
(spawn (on-start (send! "stop")))
|
||||||
|
|
||||||
(trace (assertion-added (outbound "here")))
|
(trace (message "stop"))
|
||||||
|
|
|
@ -5,6 +5,10 @@
|
||||||
;; dubious behavior by little implementation;
|
;; dubious behavior by little implementation;
|
||||||
;; create new facets from more nested facets
|
;; create new facets from more nested facets
|
||||||
|
|
||||||
|
;; The facet in the on-stop should immediately die and its assertion should never be visible.
|
||||||
|
;; Pretty sure the little implementation gets that wrong.
|
||||||
|
;; the trace does not have a way of saying there should never be an "inner" assertion
|
||||||
|
|
||||||
(spawn (on-start
|
(spawn (on-start
|
||||||
(react (on-stop
|
(react (on-stop
|
||||||
(react (assert (outbound "inner"))))))
|
(react (assert (outbound "inner"))))))
|
||||||
|
@ -13,4 +17,4 @@
|
||||||
|
|
||||||
(spawn (on-start (send! "stop")))
|
(spawn (on-start (send! "stop")))
|
||||||
|
|
||||||
(trace (assertion-added (outbound "inner")))
|
(trace (message "stop"))
|
||||||
|
|
|
@ -1,5 +1,7 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide start-tracing!)
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/string)
|
(require racket/string)
|
||||||
|
@ -12,7 +14,7 @@
|
||||||
|
|
||||||
(define-logger syndicate/trace/msd)
|
(define-logger syndicate/trace/msd)
|
||||||
|
|
||||||
(let ((output-filename (getenv "SYNDICATE_MSD")))
|
(define (start-tracing! output-filename)
|
||||||
(when output-filename
|
(when output-filename
|
||||||
(define names (make-hash (list (cons '() "'ground"))))
|
(define names (make-hash (list (cons '() "'ground"))))
|
||||||
(define (open-output cause)
|
(define (open-output cause)
|
||||||
|
@ -104,3 +106,5 @@
|
||||||
(loop)))))
|
(loop)))))
|
||||||
(channel-get ch)
|
(channel-get ch)
|
||||||
(current-trace-procedures (cons msd-trace (current-trace-procedures))))))
|
(current-trace-procedures (cons msd-trace (current-trace-procedures))))))
|
||||||
|
|
||||||
|
(start-tracing! (getenv "SYNDICATE_MSD"))
|
||||||
|
|
|
@ -0,0 +1,4 @@
|
||||||
|
*.pml
|
||||||
|
*.trail
|
||||||
|
*.rktd
|
||||||
|
*.tmp
|
|
@ -5,5 +5,7 @@ pan.c : leader-and-seller.pml
|
||||||
spin -a leader-and-seller.pml
|
spin -a leader-and-seller.pml
|
||||||
|
|
||||||
# -a to analyze, -f for (weak) fairness
|
# -a to analyze, -f for (weak) fairness
|
||||||
|
# -n to elide report of unreached states
|
||||||
|
# -N spec-name to verify a particular specification
|
||||||
check: pan
|
check: pan
|
||||||
./pan -a -f
|
./pan -a -f -n
|
||||||
|
|
|
@ -1,27 +0,0 @@
|
||||||
#lang typed/syndicate
|
|
||||||
|
|
||||||
(define-type-alias ds-type
|
|
||||||
(U (Observe (Tuple String ★)) (Tuple String Int)))
|
|
||||||
|
|
||||||
(dataspace ds-type
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(facet _
|
|
||||||
(fields [the-thing Int 0])
|
|
||||||
(assert (tuple "the thing" (ref the-thing)))
|
|
||||||
(on (asserted (tuple "set thing" (bind new-v Int)))
|
|
||||||
(set! the-thing new-v))))
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(let [k (λ [10 (begin)]
|
|
||||||
[(bind x Int)
|
|
||||||
(facet _ (fields)
|
|
||||||
(assert (tuple "set thing" (+ x 1))))])]
|
|
||||||
(facet _ (fields)
|
|
||||||
(on (asserted (tuple "the thing" (bind x Int)))
|
|
||||||
(k x)))))
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(facet _ (fields)
|
|
||||||
(on (asserted (tuple "the thing" (bind t Int)))
|
|
||||||
(displayln t)))))
|
|
|
@ -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
|
||||||
|
@ -34,14 +34,14 @@
|
||||||
(define-type-alias τc
|
(define-type-alias τc
|
||||||
(U BookQuote
|
(U BookQuote
|
||||||
(Observe (BookQuoteT String ★/t))
|
(Observe (BookQuoteT String ★/t))
|
||||||
(Observe (Observe (BookQuoteT ★/t ★/t)))
|
(Observe (Observe★ BookQuoteT))
|
||||||
ClubMember
|
ClubMember
|
||||||
(Observe (ClubMemberT ★/t))
|
(Observe★ ClubMemberT)
|
||||||
BookInterest
|
BookInterest
|
||||||
(Observe (BookInterestT String ★/t ★/t))
|
(Observe (BookInterestT String ★/t ★/t))
|
||||||
(Observe (Observe (BookInterestT ★/t ★/t ★/t)))
|
(Observe (Observe★ BookInterestT))
|
||||||
BookOfTheMonth
|
BookOfTheMonth
|
||||||
(Observe (BookOfTheMonthT ★/t))))
|
(Observe★ BookOfTheMonthT)))
|
||||||
|
|
||||||
(define-type-alias Inventory (List (Tuple String Int)))
|
(define-type-alias Inventory (List (Tuple String Int)))
|
||||||
|
|
||||||
|
@ -59,17 +59,19 @@
|
||||||
(Role (_)
|
(Role (_)
|
||||||
;; nb no mention of retracting this assertion
|
;; nb no mention of retracting this assertion
|
||||||
(Shares (BookQuoteT String Int))))))
|
(Shares (BookQuoteT String Int))))))
|
||||||
|
(export-type "seller-role.rktd" seller-role)
|
||||||
|
|
||||||
(define (spawn-seller [inventory : Inventory])
|
(define (spawn-seller [inventory : Inventory])
|
||||||
(spawn τc
|
(spawn τc
|
||||||
(begin
|
(export-roles "seller-impl.rktd"
|
||||||
|
(lift+define-role seller-impl
|
||||||
(start-facet seller
|
(start-facet seller
|
||||||
(field [books Inventory inventory])
|
(field [books Inventory inventory])
|
||||||
|
|
||||||
;; Give quotes to interested parties.
|
;; Give quotes to interested parties.
|
||||||
(during (observe (book-quote $title _))
|
(during (observe (book-quote $title _))
|
||||||
;; TODO - lookup
|
;; TODO - lookup
|
||||||
(assert (book-quote title (lookup title (ref books)))))))))
|
(assert (book-quote title (lookup title (! books))))))))))
|
||||||
|
|
||||||
(define-type-alias leader-role
|
(define-type-alias leader-role
|
||||||
(Role (leader)
|
(Role (leader)
|
||||||
|
@ -77,16 +79,16 @@
|
||||||
(Role (poll)
|
(Role (poll)
|
||||||
(Reacts (Asserted (BookInterestT String String Bool))
|
(Reacts (Asserted (BookInterestT String String Bool))
|
||||||
;; this is actually implemented indirectly through dataflow
|
;; this is actually implemented indirectly through dataflow
|
||||||
(U (Stop leader
|
(Branch (Stop leader
|
||||||
(Role (_)
|
(Role (_)
|
||||||
(Shares (BookOfTheMonthT String))))
|
(Shares (BookOfTheMonthT String))))
|
||||||
(Stop poll)))))))
|
(Stop poll)))))))
|
||||||
|
|
||||||
(define-type-alias leader-actual
|
(define-type-alias leader-actual
|
||||||
(Role (get-quotes31)
|
(Role (get-quotes)
|
||||||
(Reacts (Asserted (BookQuoteT String (Bind Int)))
|
(Reacts (Asserted (BookQuoteT String (Bind Int)))
|
||||||
(Stop get-quotes)
|
(Stop get-quotes)
|
||||||
(Role (poll-members36)
|
(Role (poll-members)
|
||||||
(Reacts OnDataflow
|
(Reacts OnDataflow
|
||||||
(Stop poll-members
|
(Stop poll-members
|
||||||
(Stop get-quotes))
|
(Stop get-quotes))
|
||||||
|
@ -102,59 +104,60 @@
|
||||||
|
|
||||||
(define (spawn-leader [titles : (List String)])
|
(define (spawn-leader [titles : (List String)])
|
||||||
(spawn τc
|
(spawn τc
|
||||||
(print-role
|
(export-roles "leader-impl.rktd"
|
||||||
|
(lift+define-role leader-impl
|
||||||
(start-facet get-quotes
|
(start-facet get-quotes
|
||||||
(field [book-list (List String) (rest titles)]
|
(field [book-list (List String) (rest titles)]
|
||||||
[title String (first titles)])
|
[title String (first titles)])
|
||||||
(define (next-book)
|
(define (next-book)
|
||||||
(cond
|
(cond
|
||||||
[(empty? (ref book-list))
|
[(empty? (! book-list))
|
||||||
(printf "leader fails to find a suitable book\n")
|
(printf "leader fails to find a suitable book\n")
|
||||||
(stop get-quotes)]
|
(stop get-quotes)]
|
||||||
[#t
|
[#t
|
||||||
(set! title (first (ref book-list)))
|
(:= title (first (! book-list)))
|
||||||
(set! book-list (rest (ref book-list)))]))
|
(:= book-list (rest (! book-list)))]))
|
||||||
|
|
||||||
;; keep track of book club members
|
;; keep track of book club members
|
||||||
(define/query-set members (club-member $name) name
|
(define/query-set members (club-member $name) name
|
||||||
#;#:on-add #;(printf "leader acknowledges member ~a\n" name))
|
#;#:on-add #;(printf "leader acknowledges member ~a\n" name))
|
||||||
|
|
||||||
(on (asserted (book-quote (ref title) $quantity))
|
(on (asserted (book-quote (! title) $quantity))
|
||||||
(printf "leader learns that there are ~a copies of ~a\n" quantity (ref title))
|
(printf "leader learns that there are ~a copies of ~a\n" quantity (! title))
|
||||||
(cond
|
(cond
|
||||||
[(< quantity (+ 1 (set-count (ref members))))
|
[(< quantity (+ 1 (set-count (! members))))
|
||||||
;; not enough in stock for each member
|
;; not enough in stock for each member
|
||||||
(next-book)]
|
(next-book)]
|
||||||
[#t
|
[#t
|
||||||
;; find out if at least half of the members want to read the book
|
;; find out if at least half of the members want to read the book
|
||||||
(start-facet poll-members
|
(start-facet poll-members
|
||||||
(define/query-set yays (book-interest (ref title) $name #t) name)
|
(define/query-set yays (book-interest (! title) $name #t) name)
|
||||||
(define/query-set nays (book-interest (ref title) $name #f) name)
|
(define/query-set nays (book-interest (! title) $name #f) name)
|
||||||
(on (asserted (book-interest (ref title) $name _))
|
(on (asserted (book-interest (! title) $name _))
|
||||||
;; count the leader as a 'yay'
|
;; count the leader as a 'yay'
|
||||||
(when (>= (set-count (ref yays))
|
(when (>= (set-count (! yays))
|
||||||
(/ (set-count (ref members)) 2))
|
(/ (set-count (! members)) 2))
|
||||||
(printf "leader finds enough affirmation for ~a\n" (ref title))
|
(printf "leader finds enough affirmation for ~a\n" (! title))
|
||||||
(stop get-quotes
|
(stop get-quotes
|
||||||
(start-facet announce
|
(start-facet announce
|
||||||
(assert (book-of-the-month (ref title))))))
|
(assert (book-of-the-month (! title))))))
|
||||||
(when (> (set-count (ref nays))
|
(when (> (set-count (! nays))
|
||||||
(/ (set-count (ref members)) 2))
|
(/ (set-count (! members)) 2))
|
||||||
(printf "leader finds enough negative nancys for ~a\n" (ref title))
|
(printf "leader finds enough negative nancys for ~a\n" (! title))
|
||||||
(stop poll-members (next-book))))
|
(stop poll-members (next-book))))
|
||||||
;; begin/dataflow is a problem for simulation checking
|
;; begin/dataflow is a problem for simulation checking
|
||||||
#;(begin/dataflow
|
#;(begin/dataflow
|
||||||
;; count the leader as a 'yay'
|
;; count the leader as a 'yay'
|
||||||
(when (>= (set-count (ref yays))
|
(when (>= (set-count (! yays))
|
||||||
(/ (set-count (ref members)) 2))
|
(/ (set-count (! members)) 2))
|
||||||
(printf "leader finds enough affirmation for ~a\n" (ref title))
|
(printf "leader finds enough affirmation for ~a\n" (! title))
|
||||||
(stop get-quotes
|
(stop get-quotes
|
||||||
(start-facet announce
|
(start-facet announce
|
||||||
(assert (book-of-the-month (ref title))))))
|
(assert (book-of-the-month (! title))))))
|
||||||
(when (> (set-count (ref nays))
|
(when (> (set-count (! nays))
|
||||||
(/ (set-count (ref members)) 2))
|
(/ (set-count (! members)) 2))
|
||||||
(printf "leader finds enough negative nancys for ~a\n" (ref title))
|
(printf "leader finds enough negative nancys for ~a\n" (! title))
|
||||||
(stop poll-members (next-book)))))]))))))
|
(stop poll-members (next-book)))))])))))))
|
||||||
|
|
||||||
(define-type-alias member-role
|
(define-type-alias member-role
|
||||||
(Role (member)
|
(Role (member)
|
||||||
|
@ -167,7 +170,8 @@
|
||||||
(define (spawn-club-member [name : String]
|
(define (spawn-club-member [name : String]
|
||||||
[titles : (List String)])
|
[titles : (List String)])
|
||||||
(spawn τc
|
(spawn τc
|
||||||
(print-role
|
(export-roles "member-impl.rktd"
|
||||||
|
(lift+define-role member-impl
|
||||||
(start-facet member
|
(start-facet member
|
||||||
;; assert our presence
|
;; assert our presence
|
||||||
(assert (club-member name))
|
(assert (club-member name))
|
||||||
|
@ -175,7 +179,7 @@
|
||||||
(during (observe (book-interest $title _ _))
|
(during (observe (book-interest $title _ _))
|
||||||
(define answer (member? title titles))
|
(define answer (member? title titles))
|
||||||
(printf "~a responds to suggested book ~a: ~a\n" name title answer)
|
(printf "~a responds to suggested book ~a: ~a\n" name title answer)
|
||||||
(assert (book-interest title name answer)))))))
|
(assert (book-interest title name answer))))))))
|
||||||
|
|
||||||
(run-ground-dataspace τc
|
(run-ground-dataspace τc
|
||||||
(spawn-seller (list (tuple "The Wind in the Willows" 5)
|
(spawn-seller (list (tuple "The Wind in the Willows" 5)
|
||||||
|
@ -187,3 +191,19 @@
|
||||||
"Encyclopaedia Brittannica"))
|
"Encyclopaedia Brittannica"))
|
||||||
(spawn-club-member "tony" (list "Candide"))
|
(spawn-club-member "tony" (list "Candide"))
|
||||||
(spawn-club-member "sam" (list "Encyclopaedia Brittannica" "Candide")))
|
(spawn-club-member "sam" (list "Encyclopaedia Brittannica" "Candide")))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(verify-actors (And (Eventually (A BookQuote))
|
||||||
|
(Always (Implies (A (Observe (BookQuoteT String ★/t)))
|
||||||
|
(Eventually (A BookQuote))))
|
||||||
|
(Always (Implies (A (Observe (BookInterestT String ★/t ★/t)))
|
||||||
|
(Eventually (A BookInterest)))))
|
||||||
|
leader-impl
|
||||||
|
seller-impl
|
||||||
|
member-impl))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-simulates leader-impl leader-impl)
|
||||||
|
(check-has-simulating-subgraph leader-impl leader-role)
|
||||||
|
(check-simulates seller-impl seller-impl)
|
||||||
|
(check-has-simulating-subgraph seller-impl seller-role))
|
|
@ -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
|
||||||
|
|
||||||
|
@ -22,11 +22,11 @@
|
||||||
(Role (cell-factory)
|
(Role (cell-factory)
|
||||||
(Reacts (Message (CreateCellT ID Value))
|
(Reacts (Message (CreateCellT ID Value))
|
||||||
;; want to say that what it spawns is a Cell
|
;; want to say that what it spawns is a Cell
|
||||||
(Spawn ★/t))))
|
(ActorWithRole ★/t Cell))))
|
||||||
|
|
||||||
(define-type-alias Reader
|
(define-type-alias Reader
|
||||||
(Role (reader)
|
(Role (reader)
|
||||||
(Shares (Observe (Cell ID ★/t)))))
|
(Shares (Observe (CellT ID ★/t)))))
|
||||||
|
|
||||||
(define-type-alias Writer
|
(define-type-alias Writer
|
||||||
(Role (writer)
|
(Role (writer)
|
||||||
|
@ -68,4 +68,4 @@
|
||||||
(on (asserted (cell id (bind value Value)))
|
(on (asserted (cell id (bind value Value)))
|
||||||
(printf "Cell ~a updated to: ~a\n" id value))
|
(printf "Cell ~a updated to: ~a\n" id value))
|
||||||
(on (retracted (cell id discard))
|
(on (retracted (cell id discard))
|
||||||
(printf "Cell ~a deleted\n" id)))))
|
(printf "Cell ~a deleted\n" id)))))
|
|
@ -1,6 +1,6 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require "../../drivers/tcp.rkt")
|
(require typed/syndicate/drivers/tcp)
|
||||||
|
|
||||||
;; message
|
;; message
|
||||||
(define-constructor (speak who what)
|
(define-constructor (speak who what)
|
||||||
|
@ -26,8 +26,7 @@
|
||||||
|
|
||||||
(spawn chat-ds
|
(spawn chat-ds
|
||||||
(start-facet chat-server
|
(start-facet chat-server
|
||||||
;; TODO - should be during/spawn
|
(during/spawn (tcp-connection (bind id Symbol) (tcp-listener 5999))
|
||||||
(during (tcp-connection (bind id Symbol) (tcp-listener 5999))
|
|
||||||
(assert (tcp-accepted id))
|
(assert (tcp-accepted id))
|
||||||
(let ([me (gensym 'user)])
|
(let ([me (gensym 'user)])
|
||||||
(assert (present me))
|
(assert (present me))
|
|
@ -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,8 +1,9 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; Protocol
|
;; Protocol
|
||||||
|
|
||||||
|
|
||||||
#|
|
#|
|
||||||
Conversations in the flink dataspace primarily concern two topics: presence and
|
Conversations in the flink dataspace primarily concern two topics: presence and
|
||||||
task execution.
|
task execution.
|
||||||
|
@ -114,7 +115,8 @@ JobManager and the TaskManager, and one between the TaskManager and its
|
||||||
TaskRunners.
|
TaskRunners.
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(define-type-alias TaskAssigner
|
;; I think this is wrong by explicitly requiring that the facet stop in response
|
||||||
|
(define-type-alias TaskAssigner-v1
|
||||||
(Role (assign)
|
(Role (assign)
|
||||||
(Shares (Observe (TaskPerformance ID ConcreteTask ★/t)))
|
(Shares (Observe (TaskPerformance ID ConcreteTask ★/t)))
|
||||||
;; would be nice to say how the TaskIDs relate to each other
|
;; would be nice to say how the TaskIDs relate to each other
|
||||||
|
@ -122,6 +124,14 @@ TaskRunners.
|
||||||
(Branch (Stop assign)
|
(Branch (Stop assign)
|
||||||
(Effs)))))
|
(Effs)))))
|
||||||
|
|
||||||
|
(define-type-alias TaskAssigner
|
||||||
|
(Role (assign)
|
||||||
|
;; would be nice to say how the TaskIDs relate to each other
|
||||||
|
(Reacts (Asserted (TaskPerformance ID ConcreteTask TaskStateDesc))
|
||||||
|
)))
|
||||||
|
|
||||||
|
(export-type "task-assigner.rktd" TaskAssigner)
|
||||||
|
|
||||||
(define-type-alias TaskPerformer
|
(define-type-alias TaskPerformer
|
||||||
(Role (listen)
|
(Role (listen)
|
||||||
(During (Observe (TaskPerformance ID ConcreteTask ★/t))
|
(During (Observe (TaskPerformance ID ConcreteTask ★/t))
|
||||||
|
@ -151,12 +161,12 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(Observe (Observe (TaskPerformance ID ★/t ★/t)))
|
(Observe (Observe (TaskPerformance ID ★/t ★/t)))
|
||||||
(JobManagerAlive)
|
(JobManagerAlive)
|
||||||
(Observe (JobManagerAlive))
|
(Observe (JobManagerAlive))
|
||||||
(Observe (TaskRunner ★/t))
|
(Observe★ TaskRunner)
|
||||||
(TaskManager ID Int)
|
(TaskManager ID Int)
|
||||||
(Observe (TaskManager ★/t ★/t))
|
(Observe★ TaskManager)
|
||||||
(JobCompletion ID (List InputTask) TaskResult)
|
(JobCompletion ID (List InputTask) TaskResult)
|
||||||
(Observe (JobCompletion ID (List InputTask) ★/t))
|
(Observe (JobCompletion ID (List InputTask) ★/t))
|
||||||
(Observe (Observe (JobCompletion ★/t ★/t ★/t)))))
|
(Observe (Observe★ JobCompletion))))
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; Util Macros
|
;; Util Macros
|
||||||
|
@ -168,9 +178,12 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(printf fmt . args)
|
(printf fmt . args)
|
||||||
(printf "\n")))
|
(printf "\n")))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; TaskRunner
|
;; TaskRunner
|
||||||
|
|
||||||
|
|
||||||
(define (word-count-increment [h : WordCount]
|
(define (word-count-increment [h : WordCount]
|
||||||
[word : String]
|
[word : String]
|
||||||
-> WordCount)
|
-> WordCount)
|
||||||
|
@ -191,8 +204,9 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
|
|
||||||
(define (spawn-task-runner [id : ID] [tm-id : ID])
|
(define (spawn-task-runner [id : ID] [tm-id : ID])
|
||||||
(spawn τc
|
(spawn τc
|
||||||
(begin
|
(export-roles "task-runner-impl.rktd"
|
||||||
(start-facet runner
|
(lift+define-role task-runner-impl
|
||||||
|
(start-facet runner ;; #:includes-behavior TaskPerformer
|
||||||
(assert (task-runner id))
|
(assert (task-runner id))
|
||||||
(on (retracted (task-manager tm-id _))
|
(on (retracted (task-manager tm-id _))
|
||||||
(stop runner))
|
(stop runner))
|
||||||
|
@ -209,16 +223,18 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(set! state (finished wc))]
|
(set! state (finished wc))]
|
||||||
[(reduce-work $left $right)
|
[(reduce-work $left $right)
|
||||||
(define wc (hash-union/combine left right +))
|
(define wc (hash-union/combine left right +))
|
||||||
(set! state (finished wc))]))))))
|
(set! state (finished wc))])))))))
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; TaskManager
|
;; TaskManager
|
||||||
|
|
||||||
|
|
||||||
(define (spawn-task-manager [num-task-runners : Int])
|
(define (spawn-task-manager [num-task-runners : Int])
|
||||||
(define id (gensym 'task-manager))
|
(define id (gensym 'task-manager))
|
||||||
(spawn τc
|
(spawn τc
|
||||||
(begin
|
(export-roles "task-manager-impl.rktd"
|
||||||
(start-facet tm
|
(#;begin lift+define-role task-manager-impl
|
||||||
|
(start-facet tm ;; #:includes-behavior TaskAssigner
|
||||||
(log "Task Manager (TM) ~a is running" id)
|
(log "Task Manager (TM) ~a is running" id)
|
||||||
(during (job-manager-alive)
|
(during (job-manager-alive)
|
||||||
(log "TM ~a learns about JM" id)
|
(log "TM ~a learns about JM" id)
|
||||||
|
@ -279,25 +295,11 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
[OVERLOAD/ts
|
[OVERLOAD/ts
|
||||||
(set! status OVERLOAD/ts)]
|
(set! status OVERLOAD/ts)]
|
||||||
[(finished discard)
|
[(finished discard)
|
||||||
(set! status st)])))))))))
|
(set! status st)]))))))))))
|
||||||
|
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; JobManager
|
;; JobManager
|
||||||
|
|
||||||
;; Task -> Bool
|
|
||||||
;; Test if the task is ready to run
|
|
||||||
(define (task-ready? [t : PendingTask] -> (Maybe ConcreteTask))
|
|
||||||
(match t
|
|
||||||
[(task $tid (map-work $s))
|
|
||||||
;; having to re-produce this is directly bc of no occurrence typing
|
|
||||||
(some (task tid (map-work s)))]
|
|
||||||
[(task $tid (reduce-work (right $v1)
|
|
||||||
(right $v2)))
|
|
||||||
(some (task tid (reduce-work v1 v2)))]
|
|
||||||
[_
|
|
||||||
none]))
|
|
||||||
|
|
||||||
;; Task Int Any -> Task
|
;; Task Int Any -> Task
|
||||||
;; If the given task is waiting for this data, replace the waiting ID with the data
|
;; If the given task is waiting for this data, replace the waiting ID with the data
|
||||||
(define (task+data [t : PendingTask]
|
(define (task+data [t : PendingTask]
|
||||||
|
@ -321,6 +323,20 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(define l (split-at/lenient- xs n))
|
(define l (split-at/lenient- xs n))
|
||||||
(tuple (first l) (second l)))
|
(tuple (first l) (second l)))
|
||||||
|
|
||||||
|
;; Task -> Bool
|
||||||
|
;; Test if the task is ready to run
|
||||||
|
(define (task-ready? [t : PendingTask] -> (Maybe ConcreteTask))
|
||||||
|
(match t
|
||||||
|
[(task $tid (map-work $s))
|
||||||
|
;; having to re-produce this is directly bc of no occurrence typing
|
||||||
|
(some (task tid (map-work s)))]
|
||||||
|
[(task $tid (reduce-work (right $v1)
|
||||||
|
(right $v2)))
|
||||||
|
(some (task tid (reduce-work v1 v2)))]
|
||||||
|
[_
|
||||||
|
none]))
|
||||||
|
|
||||||
|
|
||||||
(define (partition-ready-tasks [tasks : (List PendingTask)]
|
(define (partition-ready-tasks [tasks : (List PendingTask)]
|
||||||
-> (Tuple (List PendingTask)
|
-> (Tuple (List PendingTask)
|
||||||
(List ConcreteTask)))
|
(List ConcreteTask)))
|
||||||
|
@ -333,6 +349,7 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
[none
|
[none
|
||||||
(left t)]))))
|
(left t)]))))
|
||||||
|
|
||||||
|
|
||||||
(define (input->pending-task [t : InputTask] -> PendingTask)
|
(define (input->pending-task [t : InputTask] -> PendingTask)
|
||||||
(match t
|
(match t
|
||||||
[(task $id (map-work $s))
|
[(task $id (map-work $s))
|
||||||
|
@ -341,45 +358,82 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
[(task $id (reduce-work $l $r))
|
[(task $id (reduce-work $l $r))
|
||||||
(task id (reduce-work (left l) (left r)))]))
|
(task id (reduce-work (left l) (left r)))]))
|
||||||
|
|
||||||
(assertion-struct assigned-task : SelectedTM (mngr))
|
|
||||||
(message-struct tasks-finished : TasksFinished (id results))
|
(message-struct tasks-finished : TasksFinished (id results))
|
||||||
|
|
||||||
|
;; assertions used for internal slot-management protocol
|
||||||
|
(assertion-struct slots : Slots (v))
|
||||||
|
(assertion-struct slot-assignment : SlotAssignment (who mngr))
|
||||||
|
;; tid is the TaskID, rid is a unique symbol to a particular request for a slot
|
||||||
|
(define-constructor* (request-id : ReqID tid rid))
|
||||||
|
(define-type-alias RequestID (ReqID TaskID ID))
|
||||||
|
(message-struct task-is-ready : TaskIsReady (job-id task))
|
||||||
|
|
||||||
(define (spawn-job-manager)
|
(define (spawn-job-manager)
|
||||||
(spawn τc
|
(spawn τc
|
||||||
(begin
|
(lift+define-role job-manager-impl ;; export-roles "job-manager-impl.rktd"
|
||||||
(start-facet jm
|
(start-facet jm ;; #:includes-behavior TaskAssigner
|
||||||
(assert (job-manager-alive))
|
(assert (job-manager-alive))
|
||||||
(log "Job Manager Up")
|
(log "Job Manager Up")
|
||||||
|
|
||||||
;; keep track of task managers, how many slots they say are open, and how many tasks we have assigned.
|
(on start
|
||||||
(define/query-hash task-managers (task-manager $id $slots) id slots
|
(start-facet slot-manager
|
||||||
#:on-add (log "JM learns that ~a has ~v slots" id (hash-ref (ref task-managers) id)))
|
;; keep track of task managers, how many slots they say are open, and how many tasks we have assigned.
|
||||||
|
(define/query-hash task-managers (task-manager $id:ID $slots:Int) id slots
|
||||||
|
#:on-add (log "JM learns that ~a has ~v slots" id (hash-ref (ref task-managers) id)))
|
||||||
|
|
||||||
;; (Hashof TaskManagerID Nat)
|
(field ;; how many outstanding assignments there are for each task manager
|
||||||
;; to better understand the supply of slots for each task manager, keep track of the number
|
[requests-in-flight (Hash ID Int) (hash)]
|
||||||
;; of requested tasks that we have yet to hear back about
|
;; map a request's ID to the manager it is assigned to
|
||||||
(field [requests-in-flight (Hash ID Int) (hash)])
|
[assignments (Hash ID ID) (hash)])
|
||||||
(define (slots-available)
|
(define (slots-available)
|
||||||
(for/sum ([(id v) (ref task-managers)])
|
(for/sum ([(id v) (ref task-managers)])
|
||||||
(max 0 (- v (hash-ref/failure (ref requests-in-flight) id 0)))))
|
(max 0 (- v (hash-ref/failure (ref requests-in-flight) id 0)))))
|
||||||
|
|
||||||
;; ID -> Void
|
(define (try-take-slot! [me : ID] -> (Maybe ID))
|
||||||
;; mark that we have requested the given task manager to perform a task
|
(define mngr?
|
||||||
(define (take-slot! [id : ID])
|
(for/first ([(id slots) (ref task-managers)]
|
||||||
(log "JM assigns a task to ~a" id)
|
#:when (positive? (- slots (hash-ref/failure (ref requests-in-flight) id 0))))
|
||||||
(set! requests-in-flight (hash-update/failure (ref requests-in-flight) id add1 0)))
|
id))
|
||||||
;; ID -> Void
|
(match mngr?
|
||||||
;; mark that we have heard back from the given manager about a requested task
|
[(some $m)
|
||||||
(define (received-answer! [id : ID])
|
(set! assignments (hash-set (ref assignments) me m))
|
||||||
(set! requests-in-flight (hash-update (ref requests-in-flight) id sub1)))
|
(set! requests-in-flight (hash-update/failure (ref requests-in-flight) m add1 0))]
|
||||||
|
[none
|
||||||
|
#f])
|
||||||
|
mngr?)
|
||||||
|
|
||||||
|
(know (slots (slots-available)))
|
||||||
|
|
||||||
|
(during (know (observe (slot-assignment (request-id $tid:TaskID $who:ID) _)))
|
||||||
|
(on start
|
||||||
|
(start-facet assign-manager
|
||||||
|
;; what if one manager gains a slot but another loses one, so n stays the same?
|
||||||
|
(on (know (slots $n:Int))
|
||||||
|
#;(log "Dispatcher request ~a learns there are ~a slots" tid n)
|
||||||
|
(unless (or (zero? n) (hash-has-key? (ref assignments) who))
|
||||||
|
(define mngr? (try-take-slot! who))
|
||||||
|
(match mngr?
|
||||||
|
[(some $mngr)
|
||||||
|
(stop assign-manager
|
||||||
|
(log "Dispatcher assigns task ~a to ~a" tid mngr)
|
||||||
|
(start-facet _ (know (slot-assignment (request-id tid who) mngr)))
|
||||||
|
(start-facet waiting-for-answer
|
||||||
|
(on (asserted (observe (task-performance mngr (task tid $x) _)))
|
||||||
|
(start-facet _ (on (asserted (task-performance mngr (task tid x) _))
|
||||||
|
(log "Dispatcher sees answer for ~a" tid)
|
||||||
|
(stop waiting-for-answer))))
|
||||||
|
(on stop
|
||||||
|
(set! requests-in-flight (hash-update (ref requests-in-flight) mngr sub1)))))]
|
||||||
|
[_ #f])))))
|
||||||
|
(on stop (set! assignments (hash-remove (ref assignments) who))))))
|
||||||
|
|
||||||
(during (observe (job-completion $job-id $tasks _))
|
(during (observe (job-completion $job-id $tasks _))
|
||||||
(log "JM receives job ~a" job-id)
|
(log "JM receives job ~a" job-id)
|
||||||
(define pending (for/list ([t tasks])
|
(define pending (for/list ([t tasks])
|
||||||
(input->pending-task t)))
|
(input->pending-task t)))
|
||||||
(define-tuple (not-ready ready) (partition-ready-tasks pending))
|
(define-tuple (not-ready ready) (partition-ready-tasks pending))
|
||||||
(field [ready-tasks (List ConcreteTask) ready]
|
(field [waiting-tasks (List PendingTask) not-ready]
|
||||||
[waiting-tasks (List PendingTask) not-ready]
|
|
||||||
[tasks-in-progress Int 0])
|
[tasks-in-progress Int 0])
|
||||||
|
|
||||||
;; Task -> Void
|
;; Task -> Void
|
||||||
|
@ -387,7 +441,7 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
;; TODO - use functional-queue.rkt from ../../
|
;; TODO - use functional-queue.rkt from ../../
|
||||||
(match-define (task $tid _) t)
|
(match-define (task $tid _) t)
|
||||||
(log "JM marks task ~a as ready" tid)
|
(log "JM marks task ~a as ready" tid)
|
||||||
(set! ready-tasks (cons t (ref ready-tasks))))
|
(realize! (task-is-ready job-id t)))
|
||||||
|
|
||||||
;; ID Data -> Void
|
;; ID Data -> Void
|
||||||
;; Update any dependent tasks with the results of the given task, moving
|
;; Update any dependent tasks with the results of the given task, moving
|
||||||
|
@ -396,7 +450,6 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
[data : TaskResult])
|
[data : TaskResult])
|
||||||
(cond
|
(cond
|
||||||
[(and (zero? (ref tasks-in-progress))
|
[(and (zero? (ref tasks-in-progress))
|
||||||
(empty? (ref ready-tasks))
|
|
||||||
(empty? (ref waiting-tasks)))
|
(empty? (ref waiting-tasks)))
|
||||||
(log "JM finished with job ~a" job-id)
|
(log "JM finished with job ~a" job-id)
|
||||||
(realize! (tasks-finished job-id data))]
|
(realize! (tasks-finished job-id data))]
|
||||||
|
@ -418,32 +471,20 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
;; Requires (task-ready? t)
|
;; Requires (task-ready? t)
|
||||||
(define (∀ (ρ) (perform-task [t : ConcreteTask]
|
(define (∀ (ρ) (perform-task [t : ConcreteTask]
|
||||||
[k : (proc TaskID TaskResult -> ★/t
|
[k : (proc TaskID TaskResult -> ★/t
|
||||||
#:roles (ρ))]))
|
#:effects (ρ))]))
|
||||||
(start-facet perform
|
(start-facet perform
|
||||||
(on start (set! tasks-in-progress (add1 (ref tasks-in-progress))))
|
(on start (set! tasks-in-progress (add1 (ref tasks-in-progress))))
|
||||||
(on stop (set! tasks-in-progress (sub1 (ref tasks-in-progress))))
|
(on stop (set! tasks-in-progress (sub1 (ref tasks-in-progress))))
|
||||||
(match-define (task $this-id $desc) t)
|
(match-define (task $this-id $desc) t)
|
||||||
(log "JM begins on task ~a" this-id)
|
(log "JM begins on task ~a" this-id)
|
||||||
|
|
||||||
(define not-a-real-task-manager (gensym 'FAKE))
|
|
||||||
(field [task-mngr ID not-a-real-task-manager])
|
|
||||||
|
|
||||||
;; ID -> ...
|
;; ID -> ...
|
||||||
(define (assign-task [mngr : ID])
|
(define (∀ (ρ) (assign-task [mngr : ID]
|
||||||
|
[request-again! : (proc -> ★/t #:effects (ρ))]))
|
||||||
(start-facet assign
|
(start-facet assign
|
||||||
(know (assigned-task mngr))
|
|
||||||
(on (retracted (task-manager mngr _))
|
(on (retracted (task-manager mngr _))
|
||||||
;; our task manager has crashed
|
;; our task manager has crashed
|
||||||
(stop assign))
|
(stop assign (request-again!)))
|
||||||
(on start
|
|
||||||
;; N.B. when this line was here, and not after `(when mngr ...)` above,
|
|
||||||
;; things didn't work. I think that due to script scheduling, all ready
|
|
||||||
;; tasks were being assigned to the manager
|
|
||||||
#;(take-slot! mngr)
|
|
||||||
(start-facet take-slot
|
|
||||||
(on (asserted (task-performance mngr t _))
|
|
||||||
(stop take-slot
|
|
||||||
(received-answer! mngr)))))
|
|
||||||
(on (asserted (task-performance mngr t $status))
|
(on (asserted (task-performance mngr t $status))
|
||||||
(match status
|
(match status
|
||||||
[ACCEPTED #f]
|
[ACCEPTED #f]
|
||||||
|
@ -453,36 +494,17 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
;; don't think we need a release-slot! here, because if we've heard back from a task manager,
|
;; don't think we need a release-slot! here, because if we've heard back from a task manager,
|
||||||
;; they should have told us a different slot count since we tried to give them work
|
;; they should have told us a different slot count since we tried to give them work
|
||||||
(log "JM overloaded manager ~a with task ~a" mngr this-id)
|
(log "JM overloaded manager ~a with task ~a" mngr this-id)
|
||||||
(stop assign)]
|
(stop assign (request-again!))]
|
||||||
[(finished $results)
|
[(finished $results)
|
||||||
(log "JM receives the results of task ~a" this-id)
|
(log "JM receives the results of task ~a" this-id)
|
||||||
(stop perform (k this-id results))]))))
|
(stop perform (k this-id results))]))))
|
||||||
|
|
||||||
(define (select-a-task-manager)
|
(define (select-a-task-manager)
|
||||||
(start-facet select
|
(start-facet select
|
||||||
|
(field [req-id ID (gensym 'perform-task)])
|
||||||
(field [mngr (Maybe ID) none])
|
(define (request-again!) (set! req-id (gensym 'perform-task)))
|
||||||
|
(on (know (slot-assignment (request-id this-id (ref req-id)) $mngr:ID))
|
||||||
(define (try-assign!)
|
(assign-task mngr request-again!))))
|
||||||
(define mngr?
|
|
||||||
(for/first ([(id slots) (ref task-managers)]
|
|
||||||
#:when (positive? (- slots (hash-ref/failure (ref requests-in-flight) id 0))))
|
|
||||||
id))
|
|
||||||
(match mngr?
|
|
||||||
[(some $m)
|
|
||||||
(take-slot! m)
|
|
||||||
(set! mngr (some m))
|
|
||||||
(assign-task m)]
|
|
||||||
[none
|
|
||||||
#f]))
|
|
||||||
|
|
||||||
(begin/dataflow
|
|
||||||
(when (equal? (ref mngr) none)
|
|
||||||
(try-assign!)))
|
|
||||||
|
|
||||||
(on (forget (assigned-task $m:ID))
|
|
||||||
(when (equal? (some m) (ref mngr))
|
|
||||||
(set! mngr none)))))
|
|
||||||
|
|
||||||
(on start (select-a-task-manager))))
|
(on start (select-a-task-manager))))
|
||||||
|
|
||||||
|
@ -491,15 +513,10 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(on (realize (tasks-finished job-id $data:TaskResult))
|
(on (realize (tasks-finished job-id $data:TaskResult))
|
||||||
(stop delegate-tasks
|
(stop delegate-tasks
|
||||||
(start-facet done (assert (job-completion job-id tasks data)))))
|
(start-facet done (assert (job-completion job-id tasks data)))))
|
||||||
(begin/dataflow
|
(on (realize (task-is-ready job-id $t:ConcreteTask))
|
||||||
(define slots (slots-available))
|
(perform-task t push-results)))
|
||||||
(define-tuple (ts readys)
|
(for ([t (in-list ready)])
|
||||||
(split-at/lenient (ref ready-tasks) slots))
|
(add-ready-task! t))))))))
|
||||||
(for ([t ts])
|
|
||||||
(perform-task t push-results))
|
|
||||||
(unless (empty? ts)
|
|
||||||
;; the empty? check may be necessary to avoid a dataflow loop
|
|
||||||
(set! ready-tasks readys))))))))))
|
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; Client
|
;; Client
|
||||||
|
@ -507,10 +524,12 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
;; Job -> Void
|
;; Job -> Void
|
||||||
(define (spawn-client [j : JobDesc])
|
(define (spawn-client [j : JobDesc])
|
||||||
(spawn τc
|
(spawn τc
|
||||||
|
(export-roles "client-impl.rktd"
|
||||||
|
(lift+define-role client-impl
|
||||||
(start-facet _
|
(start-facet _
|
||||||
(match-define (job $id $tasks) j)
|
(match-define (job $id $tasks) j)
|
||||||
(on (asserted (job-completion id tasks $data))
|
(on (asserted (job-completion id tasks $data))
|
||||||
(printf "job done!\n~a\n" data)))))
|
(printf "job done!\n~a\n" data)))))))
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
;; Main
|
;; Main
|
||||||
|
@ -529,3 +548,29 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(spawn-task-manager 3)
|
(spawn-task-manager 3)
|
||||||
(spawn-client (file->job "lorem.txt"))
|
(spawn-client (file->job "lorem.txt"))
|
||||||
(spawn-client (string->job INPUT)))
|
(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)))
|
||||||
|
(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))))
|
||||||
|
job-manager-impl
|
||||||
|
task-manager-impl
|
||||||
|
client-impl)
|
||||||
|
|
||||||
|
(verify-actors (And (Always (Implies (A (Observe (TaskPerformance ID ConcreteTask ★/t)))
|
||||||
|
(Eventually (A (TaskPerformance ID ConcreteTask TaskStateDesc)))))
|
||||||
|
(Eventually (A (TaskPerformance ID ConcreteTask TaskStateDesc))))
|
||||||
|
TaskAssigner
|
||||||
|
TaskPerformer))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-simulates task-runner-impl task-runner-impl)
|
||||||
|
(check-has-simulating-subgraph task-runner-impl TaskPerformer)
|
||||||
|
(check-simulates task-manager-impl task-manager-impl)
|
||||||
|
(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))
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
;; Expected Output:
|
;; Expected Output:
|
||||||
#|
|
#|
|
|
@ -0,0 +1,48 @@
|
||||||
|
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nullam vehicula
|
||||||
|
accumsan tristique. Integer sit amet sem metus. Nam porta tempus nisl ac
|
||||||
|
ullamcorper. Nulla interdum ante ut odio ultricies lobortis. Nam sollicitudin
|
||||||
|
lorem quis pellentesque consequat. Aenean pulvinar diam sed nulla semper, eget
|
||||||
|
varius tortor faucibus. Nam sodales mattis elit, ac convallis sem pretium sed.
|
||||||
|
Aliquam nibh velit, facilisis sit amet aliquam quis, dapibus vel mauris. Cras
|
||||||
|
pharetra arcu tortor, id pharetra massa aliquet non. Maecenas elit libero,
|
||||||
|
malesuada nec enim ut, ornare sagittis lectus. Praesent bibendum sed magna id
|
||||||
|
euismod. Maecenas vulputate nunc mauris, a dignissim magna volutpat consectetur.
|
||||||
|
Fusce malesuada neque sapien, sit amet ultricies urna finibus non. Fusce
|
||||||
|
ultrices ipsum vel ligula eleifend, eget eleifend magna interdum. Curabitur
|
||||||
|
semper quam nunc, sed laoreet ipsum facilisis at. Etiam ut quam ac eros
|
||||||
|
ullamcorper mattis eget vel leo.
|
||||||
|
|
||||||
|
Integer ac ipsum augue. Ut molestie ac mi vel varius. Praesent at est et nulla
|
||||||
|
facilisis viverra sit amet eu augue. Nullam diam odio, elementum vehicula
|
||||||
|
convallis id, hendrerit non magna. Suspendisse porta faucibus feugiat. In
|
||||||
|
rhoncus semper diam eu malesuada. Suspendisse ligula metus, rhoncus eget nunc
|
||||||
|
et, cursus rutrum sem. Fusce iaculis commodo magna, vitae viverra arcu. Fusce et
|
||||||
|
eros et massa sollicitudin bibendum. Etiam convallis, nibh accumsan porttitor
|
||||||
|
sollicitudin, mauris orci consectetur nisl, sit amet venenatis nulla enim eget
|
||||||
|
risus. Phasellus quam diam, commodo in sodales eget, scelerisque sed odio. Sed
|
||||||
|
aliquam massa vel efficitur volutpat. Mauris ut elit dictum, euismod turpis in,
|
||||||
|
feugiat lectus.
|
||||||
|
|
||||||
|
Vestibulum leo est, feugiat sit amet metus nec, ullamcorper commodo purus. Sed
|
||||||
|
non mauris non tellus ullamcorper congue interdum et mauris. Donec sit amet
|
||||||
|
mauris urna. Sed in enim nisi. Praesent accumsan sagittis euismod. Donec vel
|
||||||
|
nisl turpis. Ut non efficitur erat. Vestibulum quis fermentum elit. Mauris
|
||||||
|
molestie nibh posuere fringilla rutrum. Praesent mattis tortor sapien, semper
|
||||||
|
varius elit ultrices in.
|
||||||
|
|
||||||
|
Etiam non leo lacus. Cras id tincidunt ante. Donec mattis urna fermentum ex
|
||||||
|
elementum blandit. Sed ornare vestibulum nulla luctus malesuada. Maecenas
|
||||||
|
pulvinar metus tortor. Sed dapibus enim vel sem bibendum, sit amet tincidunt
|
||||||
|
ligula varius. Nullam vitae augue at dui blandit cursus. Suspendisse faucibus
|
||||||
|
posuere luctus.
|
||||||
|
|
||||||
|
Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos
|
||||||
|
himenaeos. Aenean suscipit diam eu luctus auctor. Donec non magna quis ex
|
||||||
|
tincidunt condimentum. Ut porta maximus quam, non varius sem mattis eu. Fusce
|
||||||
|
sit amet vestibulum libero. Aliquam vestibulum sagittis mi a pellentesque. Cras
|
||||||
|
maximus cursus libero vitae porttitor. Aenean fermentum erat eget turpis mattis,
|
||||||
|
quis commodo magna pharetra. Praesent eu hendrerit arcu. Proin mollis, sem ac
|
||||||
|
accumsan dignissim, velit risus ultricies mauris, eu imperdiet dolor ipsum at
|
||||||
|
augue. Fusce bibendum, tortor eget pulvinar auctor, leo mi volutpat urna, nec
|
||||||
|
convallis sem quam non tellus. Vestibulum fermentum sodales faucibus. Nunc quis
|
||||||
|
feugiat quam. Donec pulvinar feugiat mauris non porttitor.
|
|
@ -0,0 +1,21 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
;; Expected Output:
|
||||||
|
;; got: new
|
||||||
|
|
||||||
|
(define-constructor* (something : SomethingT new blue)
|
||||||
|
#:with Something (SomethingT String Int))
|
||||||
|
|
||||||
|
(define-type-alias τc
|
||||||
|
(U Something
|
||||||
|
(Observe★ SomethingT)))
|
||||||
|
|
||||||
|
(run-ground-dataspace
|
||||||
|
τc
|
||||||
|
(spawn
|
||||||
|
(start-facet _
|
||||||
|
(assert (something "new" 42))))
|
||||||
|
(spawn
|
||||||
|
(start-facet _
|
||||||
|
(on (asserted (something $x 42))
|
||||||
|
(printf "got: ~a\n" x))))
|
||||||
|
)
|
|
@ -0,0 +1,36 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
;; Expected Output
|
||||||
|
;; pong: 8339
|
||||||
|
|
||||||
|
(message-struct ping : Ping (v))
|
||||||
|
(message-struct pong : Pong (v))
|
||||||
|
|
||||||
|
(define-type-alias ds-type
|
||||||
|
(U (Message (Ping Int))
|
||||||
|
(Message (Pong Int))
|
||||||
|
(Observe (Ping ★/t))
|
||||||
|
(Observe (Pong ★/t))
|
||||||
|
(Observe (Observe (Ping ★/t)))))
|
||||||
|
|
||||||
|
(run-ground-dataspace ds-type
|
||||||
|
(spawn ds-type
|
||||||
|
(lift+define-role ponger
|
||||||
|
(start-facet echo
|
||||||
|
(on (message (ping $v))
|
||||||
|
(send! (pong v))))))
|
||||||
|
(spawn ds-type
|
||||||
|
(lift+define-role pinger
|
||||||
|
(start-facet serve
|
||||||
|
(on (asserted (observe (ping _)))
|
||||||
|
(send! (ping 8339)))
|
||||||
|
(on (message (pong $x))
|
||||||
|
(printf "pong: ~v\n" x))))))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(verify-actors (And (Eventually (M (Ping Int)))
|
||||||
|
(Eventually (M (Pong Int)))
|
||||||
|
(Always (Implies (M (Ping Int))
|
||||||
|
(Eventually (M (Pong Int))))))
|
||||||
|
pinger
|
||||||
|
ponger))
|
|
@ -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,13 +1,16 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require-struct msg #:as Msg
|
(require-struct msg #:as Msg
|
||||||
#:from "driver.rkt")
|
#:from "driver.rkt")
|
||||||
|
|
||||||
(define m (msg 1 "hi"))
|
(define m (msg 1 "hi"))
|
||||||
|
|
||||||
|
(msg-in m)
|
||||||
|
(msg-out m)
|
||||||
|
|
||||||
(match m
|
(match m
|
||||||
[(msg (bind x Int) discard)
|
[(msg (bind x Int) discard)
|
||||||
(displayln x)])
|
(displayln x)])
|
||||||
|
|
||||||
;; error: msg/checked: arity mismatch
|
;; error: msg/checked: arity mismatch
|
||||||
#;(msg 1 2 3)
|
#;(msg 1 2 3)
|
|
@ -0,0 +1,17 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
;; using different syntax than "client.rkt"
|
||||||
|
|
||||||
|
(require/typed "driver.rkt" [#:struct msg])
|
||||||
|
|
||||||
|
(define m : (MsgT Int String) (msg 1 "hi"))
|
||||||
|
|
||||||
|
(msg-in m)
|
||||||
|
(msg-out m)
|
||||||
|
|
||||||
|
(match m
|
||||||
|
[(msg (bind x Int) discard)
|
||||||
|
(displayln x)])
|
||||||
|
|
||||||
|
;; error: msg/checked: arity mismatch
|
||||||
|
#;(msg 1 2 3)
|
|
@ -0,0 +1,12 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(struct egg (size day) #:transparent)
|
||||||
|
|
||||||
|
(provide (except-out (struct-out egg)
|
||||||
|
egg-size
|
||||||
|
egg-day))
|
||||||
|
|
||||||
|
|
||||||
|
(struct chicken (eggs) #:transparent)
|
||||||
|
|
||||||
|
(provide chicken)
|
|
@ -0,0 +1,18 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require-struct egg #:as Egg #:from "lib.rkt" #:omit-accs)
|
||||||
|
|
||||||
|
(define e (egg 5 "Sun"))
|
||||||
|
|
||||||
|
(match e
|
||||||
|
[(egg $sz $d)
|
||||||
|
(displayln sz)
|
||||||
|
(displayln d)])
|
||||||
|
|
||||||
|
(require-struct chicken #:as Chicken #:from "lib.rkt" #:omit-accs)
|
||||||
|
|
||||||
|
(define c (chicken (list e e e)))
|
||||||
|
|
||||||
|
(match c
|
||||||
|
[(chicken $eggs)
|
||||||
|
(displayln eggs)])
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require/typed "lib.rkt" [x : Int])
|
||||||
|
|
||||||
|
(displayln (+ x 1))
|
|
@ -0,0 +1,8 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require/typed "lib.rkt"
|
||||||
|
[#:opaque Vec #:arity = 3]
|
||||||
|
[ones : (Vec Int Int Int)]
|
||||||
|
[vec+ : (→fn (Vec Int Int Int) (Vec Int Int Int) (Vec Int Int Int))])
|
||||||
|
|
||||||
|
(vec+ ones ones)
|
|
@ -0,0 +1,8 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require/typed "lib.rkt"
|
||||||
|
[#:opaque Vec]
|
||||||
|
[ones : Vec]
|
||||||
|
[vec+ : (→fn Vec Vec Vec)])
|
||||||
|
|
||||||
|
(vec+ ones ones)
|
|
@ -0,0 +1,13 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(provide ones
|
||||||
|
vec+)
|
||||||
|
|
||||||
|
(struct vec (x y z) #:transparent)
|
||||||
|
|
||||||
|
(define ones (vec 1 1 1))
|
||||||
|
|
||||||
|
(define (vec+ v1 v2)
|
||||||
|
(vec (+ (vec-x v1) (vec-x v2))
|
||||||
|
(+ (vec-y v1) (vec-y v2))
|
||||||
|
(+ (vec-z v1) (vec-z v2))))
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require "provides.rkt")
|
||||||
|
|
||||||
|
(a-fun 5)
|
|
@ -1,57 +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 (Know (Deposit Int)))))
|
|
||||||
|
|
||||||
(define-type-alias client-role
|
|
||||||
(Role (client)
|
|
||||||
(Reacts (Know Account))))
|
|
||||||
|
|
||||||
(run-ground-dataspace ds-type
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(print-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
|
|
||||||
(print-role
|
|
||||||
(start-facet observer
|
|
||||||
(on (asserted (account (bind amount Int)))
|
|
||||||
(displayln amount)))))
|
|
||||||
|
|
||||||
(spawn ds-type
|
|
||||||
(print-role
|
|
||||||
(start-facet buyer
|
|
||||||
(on (asserted (observe (deposit discard)))
|
|
||||||
(start-facet deposits
|
|
||||||
(assert (deposit 100))
|
|
||||||
(assert (deposit -30))))))))
|
|
|
@ -1,20 +0,0 @@
|
||||||
#lang typed/syndicate/roles
|
|
||||||
|
|
||||||
;; Expected Output
|
|
||||||
;; pong: 8339
|
|
||||||
|
|
||||||
(define-type-alias ds-type
|
|
||||||
(U (Message (Tuple String Int))
|
|
||||||
(Observe (Tuple String ★/t))))
|
|
||||||
|
|
||||||
(run-ground-dataspace ds-type
|
|
||||||
(spawn ds-type
|
|
||||||
(start-facet echo
|
|
||||||
(on (message (tuple "ping" (bind x Int)))
|
|
||||||
(send! (tuple "pong" x)))))
|
|
||||||
(spawn ds-type
|
|
||||||
(start-facet serve
|
|
||||||
(on start
|
|
||||||
(send! (tuple "ping" 8339)))
|
|
||||||
(on (message (tuple "pong" (bind x Int)))
|
|
||||||
(printf "pong: ~v\n" x)))))
|
|
|
@ -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,148 +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 id 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)
|
|
||||||
(Reacts (Asserted (Observe (QuoteT String ★/t)))
|
|
||||||
(Role (_)
|
|
||||||
(Shares (QuoteT String Int))))))
|
|
||||||
|
|
||||||
(run-ground-dataspace ds-type
|
|
||||||
|
|
||||||
;; seller
|
|
||||||
(spawn ds-type
|
|
||||||
(start-facet _
|
|
||||||
(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))
|
|
||||||
(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)))
|
|
||||||
(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
|
|
||||||
(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
|
|
||||||
(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))]))))))])))))
|
|
||||||
)
|
|
|
@ -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
|
|
@ -0,0 +1,33 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
;; Expected Output
|
||||||
|
;; +parent
|
||||||
|
;; +GO
|
||||||
|
;; +ready
|
||||||
|
;; -parent
|
||||||
|
;; -GO
|
||||||
|
;; -ready
|
||||||
|
|
||||||
|
(define-type-alias ds-type
|
||||||
|
(U (Tuple String) (Observe (Tuple ★/t))))
|
||||||
|
|
||||||
|
(run-ground-dataspace ds-type
|
||||||
|
(spawn ds-type
|
||||||
|
(start-facet parent
|
||||||
|
(assert (tuple "parent"))
|
||||||
|
(during/spawn (tuple "GO")
|
||||||
|
(assert (tuple "ready")))
|
||||||
|
(on (asserted (tuple "ready"))
|
||||||
|
(stop parent))))
|
||||||
|
(spawn ds-type
|
||||||
|
(start-facet flag
|
||||||
|
(assert (tuple "GO"))
|
||||||
|
(on (retracted (tuple "parent"))
|
||||||
|
(stop flag))))
|
||||||
|
(spawn ds-type
|
||||||
|
(start-facet obs
|
||||||
|
(during (tuple (bind s String))
|
||||||
|
(on start
|
||||||
|
(printf "+~a\n" s))
|
||||||
|
(on stop
|
||||||
|
(printf "-~a\n" s))))))
|
|
@ -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
|
|
@ -0,0 +1,7 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require "typed-out.rkt")
|
||||||
|
|
||||||
|
(define c : (Cow Int) (cow 5))
|
||||||
|
|
||||||
|
(cow-moos c)
|
|
@ -0,0 +1,7 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require "struct-out.rkt")
|
||||||
|
|
||||||
|
(happy-days (happy 5))
|
||||||
|
|
||||||
|
(define classic : (Happy Int) (happy 100))
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(provide (struct-out happy))
|
||||||
|
|
||||||
|
(define-constructor* (happy : Happy days))
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require-struct cow #:as Cow #:from "untyped.rkt")
|
||||||
|
|
||||||
|
(provide (struct-out cow))
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(provide (struct-out cow))
|
||||||
|
|
||||||
|
(struct cow (moos) #:transparent)
|
|
@ -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))
|
||||||
|
|
|
@ -0,0 +1,22 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(define (wf1)
|
||||||
|
(spawn
|
||||||
|
(with-facets
|
||||||
|
([onn (facet (assert (tuple 'on))
|
||||||
|
(on start (printf "on\n")))]
|
||||||
|
[off (facet (on (asserted (tuple 'go))
|
||||||
|
(stop off
|
||||||
|
(start onn)))
|
||||||
|
(on start (printf "off\n")))])
|
||||||
|
off)))
|
||||||
|
|
||||||
|
(run-ground-dataspace
|
||||||
|
(wf1)
|
||||||
|
(spawn (start-facet _ (assert (tuple 'go)))))
|
||||||
|
|
||||||
|
;; BAD
|
||||||
|
#;(spawn
|
||||||
|
(with-facets
|
||||||
|
[on (facet (on start (start on)))]
|
||||||
|
on))
|
|
@ -1,8 +1,13 @@
|
||||||
#lang info
|
#lang info
|
||||||
|
|
||||||
|
(define scribblings '(("scribblings/typed-syndicate.scrbl" ())))
|
||||||
|
|
||||||
(define compile-omit-paths
|
(define compile-omit-paths
|
||||||
'("examples"
|
'("examples"
|
||||||
"tests"))
|
"tests"))
|
||||||
|
|
||||||
(define test-omit-paths
|
(define test-omit-paths
|
||||||
'("examples/roles/chat-tcp2.rkt"))
|
;; a number of the examples use SPIN for model checking which I need
|
||||||
|
;; to figure out how to get working on the package server
|
||||||
|
'("examples/"
|
||||||
|
"tests/spin/"))
|
||||||
|
|
|
@ -1,622 +0,0 @@
|
||||||
#lang turnstile
|
|
||||||
|
|
||||||
(provide #%module-begin
|
|
||||||
#%app
|
|
||||||
(rename-out [typed-quote quote])
|
|
||||||
#%top-interaction
|
|
||||||
require only-in
|
|
||||||
;; Start dataspace programs
|
|
||||||
run-ground-dataspace
|
|
||||||
;; Types
|
|
||||||
Tuple Bind Discard → ∀
|
|
||||||
Role Reacts Shares Asserted Retracted Message OnDataflow Stop OnStart OnStop
|
|
||||||
Know Forget Realize
|
|
||||||
Branch Effs
|
|
||||||
FacetName Field ★/t
|
|
||||||
Observe Inbound Outbound Actor U ⊥
|
|
||||||
Computation Value Endpoints Roles Spawns
|
|
||||||
→fn proc
|
|
||||||
;; Statements
|
|
||||||
let let* if spawn dataspace start-facet set! begin stop begin/dataflow #;unsafe-do
|
|
||||||
when unless send! realize! define
|
|
||||||
;; Derived Forms
|
|
||||||
during During
|
|
||||||
define/query-value
|
|
||||||
define/query-set
|
|
||||||
define/query-hash
|
|
||||||
define/dataflow
|
|
||||||
on-start on-stop
|
|
||||||
;; endpoints
|
|
||||||
assert know on field
|
|
||||||
;; expressions
|
|
||||||
tuple select lambda ref observe inbound outbound
|
|
||||||
Λ inst call/inst
|
|
||||||
;; making types
|
|
||||||
define-type-alias
|
|
||||||
assertion-struct
|
|
||||||
message-struct
|
|
||||||
define-constructor define-constructor*
|
|
||||||
;; values
|
|
||||||
#%datum
|
|
||||||
;; patterns
|
|
||||||
bind discard
|
|
||||||
;; primitives
|
|
||||||
(all-from-out "prim.rkt")
|
|
||||||
;; expressions
|
|
||||||
(all-from-out "core-expressions.rkt")
|
|
||||||
;; lists
|
|
||||||
(all-from-out "list.rkt")
|
|
||||||
;; sets
|
|
||||||
(all-from-out "set.rkt")
|
|
||||||
;; sequences
|
|
||||||
(all-from-out "sequence.rkt")
|
|
||||||
;; hash tables
|
|
||||||
(all-from-out "hash.rkt")
|
|
||||||
;; for loops
|
|
||||||
(all-from-out "for-loops.rkt")
|
|
||||||
;; utility datatypes
|
|
||||||
(all-from-out "maybe.rkt")
|
|
||||||
(all-from-out "either.rkt")
|
|
||||||
;; DEBUG and utilities
|
|
||||||
print-type print-role role-strings
|
|
||||||
;; Extensions
|
|
||||||
match cond
|
|
||||||
;; require & provides
|
|
||||||
require provide
|
|
||||||
submod for-syntax for-meta only-in except-in
|
|
||||||
require/typed
|
|
||||||
require-struct
|
|
||||||
)
|
|
||||||
(require "core-types.rkt")
|
|
||||||
(require "core-expressions.rkt")
|
|
||||||
(require "list.rkt")
|
|
||||||
(require "set.rkt")
|
|
||||||
(require "prim.rkt")
|
|
||||||
(require "sequence.rkt")
|
|
||||||
(require "hash.rkt")
|
|
||||||
(require "for-loops.rkt")
|
|
||||||
(require "maybe.rkt")
|
|
||||||
(require "either.rkt")
|
|
||||||
|
|
||||||
(require (prefix-in syndicate: syndicate/actor-lang))
|
|
||||||
(require (submod syndicate/actor priorities))
|
|
||||||
|
|
||||||
(require (for-meta 2 macrotypes/stx-utils racket/list syntax/stx syntax/parse racket/base))
|
|
||||||
(require macrotypes/postfix-in)
|
|
||||||
(require (for-syntax turnstile/mode))
|
|
||||||
(require (postfix-in - racket/list))
|
|
||||||
(require (postfix-in - racket/set))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(require rackunit)
|
|
||||||
(require rackunit/turnstile))
|
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Creating Communication Types
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-simple-macro (assertion-struct name:id (~datum :) Name:id (slot:id ...))
|
|
||||||
(define-constructor* (name : Name slot ...)))
|
|
||||||
|
|
||||||
(define-simple-macro (message-struct name:id (~datum :) Name:id (slot:id ...))
|
|
||||||
(define-constructor* (name : Name slot ...)))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Compile-time State
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(define current-communication-type (make-parameter #f))
|
|
||||||
;; Type -> Mode
|
|
||||||
(define (communication-type-mode ty)
|
|
||||||
(make-param-mode current-communication-type ty))
|
|
||||||
|
|
||||||
(define (elaborate-pattern/with-com-ty pat)
|
|
||||||
(define τ? (current-communication-type))
|
|
||||||
(if τ?
|
|
||||||
(elaborate-pattern/with-type pat τ?)
|
|
||||||
(elaborate-pattern pat))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Core forms
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(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-- (add-orig (internal-definition-context-introduce ctx #'name- 'add)
|
|
||||||
#'name))
|
|
||||||
(int-def-ctx-bind-type-rename #'name+ #'name- #'facet-name-ty ctx)
|
|
||||||
(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"))]
|
|
||||||
#:with ((~or (~and τ-a (~Shares _))
|
|
||||||
(~and τ-k (~Know _))
|
|
||||||
;; untyped syndicate might allow this - TODO
|
|
||||||
#;(~and τ-m (~Sends _))
|
|
||||||
(~and τ-r (~Reacts _ ...))
|
|
||||||
~MakesField)
|
|
||||||
...)
|
|
||||||
ep-effects
|
|
||||||
#:with τ (type-eval #`(Role (#,name--)
|
|
||||||
τ-a ...
|
|
||||||
τ-k ...
|
|
||||||
;; τ-m ...
|
|
||||||
τ-r ...))
|
|
||||||
--------------------------------------------------------------
|
|
||||||
[⊢ (syndicate:react (let- ([#,name-- (#%app- syndicate:current-facet-id)])
|
|
||||||
#,@ep-...))
|
|
||||||
(⇒ : ★/t)
|
|
||||||
(⇒ ν-f (τ))])
|
|
||||||
|
|
||||||
(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) ...))
|
|
||||||
#:with MF (type-eval #'MakesField)
|
|
||||||
----------------------------------------------------------------------
|
|
||||||
[⊢ (field/intermediate [x x- τ e-] ...)
|
|
||||||
(⇒ : ★/t)
|
|
||||||
(⇒ ν-ep (MF))])
|
|
||||||
|
|
||||||
(define-typed-syntax (assert e:expr) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
|
||||||
#:with τs (mk-Shares- #'(τ))
|
|
||||||
-------------------------------------
|
|
||||||
[⊢ (syndicate:assert e-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-ep (τs))])
|
|
||||||
|
|
||||||
(define-typed-syntax (know e:expr) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
|
||||||
#:with τs (mk-Know- #'(τ))
|
|
||||||
-------------------------------------
|
|
||||||
[⊢ (syndicate:know e-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-ep (τs))])
|
|
||||||
|
|
||||||
(define-typed-syntax (send! e:expr) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
|
||||||
#:with τm (mk-Sends- #'(τ))
|
|
||||||
--------------------------------------
|
|
||||||
[⊢ (#%app- syndicate:send! e-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-f (τm))])
|
|
||||||
|
|
||||||
(define-typed-syntax (realize! e:expr) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
|
||||||
#:with τm (mk-Realizes- #'(τ))
|
|
||||||
--------------------------------------
|
|
||||||
[⊢ (#%app- syndicate:realize! e-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-f (τm))])
|
|
||||||
|
|
||||||
(define-typed-syntax (stop facet-name:id cont ...) ≫
|
|
||||||
[⊢ facet-name ≫ facet-name- (⇐ : FacetName)]
|
|
||||||
[⊢ (begin #f cont ...) ≫ cont- (⇒ ν-ep (~effs)) (⇒ ν-s (~effs)) (⇒ ν-f (~effs τ-f ...))]
|
|
||||||
#:with τ (mk-Stop- #`(facet-name- τ-f ...))
|
|
||||||
---------------------------------------------------------------------------------
|
|
||||||
[⊢ (syndicate:stop-facet facet-name- cont-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-f (τ))])
|
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(define-syntax-class event-cons
|
|
||||||
#:attributes (syndicate-kw ty-cons)
|
|
||||||
#:datum-literals (asserted retracted message know forget realize)
|
|
||||||
(pattern (~or (~and asserted
|
|
||||||
(~bind [syndicate-kw #'syndicate:asserted]
|
|
||||||
[ty-cons #'Asserted]))
|
|
||||||
(~and retracted
|
|
||||||
(~bind [syndicate-kw #'syndicate:retracted]
|
|
||||||
[ty-cons #'Retracted]))
|
|
||||||
(~and message
|
|
||||||
(~bind [syndicate-kw #'syndicate:message]
|
|
||||||
[ty-cons #'Message]))
|
|
||||||
(~and know
|
|
||||||
(~bind [syndicate-kw #'syndicate:know]
|
|
||||||
[ty-cons #'Know]))
|
|
||||||
(~and forget
|
|
||||||
(~bind [syndicate-kw #'syndicate:forget]
|
|
||||||
[ty-cons #'Forget]))
|
|
||||||
(~and realize
|
|
||||||
(~bind [syndicate-kw #'syndicate:realize]
|
|
||||||
[ty-cons #'Realize])))))
|
|
||||||
(define-syntax-class priority-level
|
|
||||||
#:literals (*query-priority-high*
|
|
||||||
*query-priority*
|
|
||||||
*query-handler-priority*
|
|
||||||
*normal-priority*
|
|
||||||
*gc-priority*
|
|
||||||
*idle-priority*)
|
|
||||||
(pattern (~and level
|
|
||||||
(~or *query-priority-high*
|
|
||||||
*query-priority*
|
|
||||||
*query-handler-priority*
|
|
||||||
*normal-priority*
|
|
||||||
*gc-priority*
|
|
||||||
*idle-priority*))))
|
|
||||||
(define-splicing-syntax-class priority
|
|
||||||
#:attributes (level)
|
|
||||||
(pattern (~seq #:priority l:priority-level)
|
|
||||||
#:attr level #'l.level)
|
|
||||||
(pattern (~seq)
|
|
||||||
#:attr level #'*normal-priority*))
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-typed-syntax on
|
|
||||||
#:datum-literals (start stop)
|
|
||||||
[(on start s ...) ≫
|
|
||||||
[⊢ (begin s ...) ≫ s- (⇒ ν-ep (~effs))
|
|
||||||
(⇒ ν-f (~effs τ-f ...))
|
|
||||||
(⇒ ν-s (~effs τ-s ...))]
|
|
||||||
#:with τ-r (type-eval #'(Reacts OnStart τ-f ... τ-s ...))
|
|
||||||
-----------------------------------
|
|
||||||
[⊢ (syndicate:on-start s-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-ep (τ-r))]]
|
|
||||||
[(on stop s ...) ≫
|
|
||||||
[⊢ (begin s ...) ≫ s- (⇒ ν-ep (~effs))
|
|
||||||
(⇒ ν-f (~effs τ-f ...))
|
|
||||||
(⇒ ν-s (~effs τ-s ...))]
|
|
||||||
#:with τ-r (type-eval #'(Reacts OnStop τ-f ... τ-s ...))
|
|
||||||
-----------------------------------
|
|
||||||
[⊢ (syndicate:on-stop s-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-ep (τ-r))]]
|
|
||||||
[(on (evt:event-cons p)
|
|
||||||
priority:priority
|
|
||||||
s ...) ≫
|
|
||||||
#:do [(define msg? (free-identifier=? #'syndicate:message (attribute evt.syndicate-kw)))
|
|
||||||
(define elab
|
|
||||||
(elaborate-pattern/with-com-ty (if msg? #'(message p) #'p)))]
|
|
||||||
#:with p/e (if msg? (stx-cadr elab) elab)
|
|
||||||
[⊢ p/e ≫ p-- (⇒ : τp)]
|
|
||||||
#:fail-unless (pure? #'p--) "pattern not allowed to have effects"
|
|
||||||
#:with ([x:id τ:type] ...) (pat-bindings #'p/e)
|
|
||||||
[[x ≫ x- : τ] ... ⊢ (begin s ...) ≫ s-
|
|
||||||
(⇒ ν-ep (~effs))
|
|
||||||
(⇒ ν-f (~effs τ-f ...))
|
|
||||||
(⇒ ν-s (~effs τ-s ...))]
|
|
||||||
#:with p- (substs #'(x- ...) #'(x ...) (compile-syndicate-pattern #'p/e))
|
|
||||||
#:with τ-r (type-eval #'(Reacts (evt.ty-cons τp) τ-f ... τ-s ...))
|
|
||||||
-----------------------------------
|
|
||||||
[⊢ (syndicate:on (evt.syndicate-kw p-)
|
|
||||||
#:priority priority.level
|
|
||||||
s-)
|
|
||||||
(⇒ : ★/t)
|
|
||||||
(⇒ ν-ep (τ-r))]])
|
|
||||||
|
|
||||||
(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))])
|
|
||||||
|
|
||||||
(define-for-syntax (compile-syndicate-pattern pat)
|
|
||||||
(compile-pattern pat
|
|
||||||
#'list-
|
|
||||||
(lambda (id) #`($ #,id))
|
|
||||||
identity))
|
|
||||||
|
|
||||||
(define-typed-syntax spawn
|
|
||||||
[(spawn τ-c:type s) ≫
|
|
||||||
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
|
||||||
;; TODO: check that each τ-f is a Role
|
|
||||||
#:mode (communication-type-mode #'τ-c.norm)
|
|
||||||
[
|
|
||||||
[⊢ s ≫ s- (⇒ ν-ep (~effs)) (⇒ ν-s (~effs)) (⇒ ν-f (~effs τ-f ...))]
|
|
||||||
]
|
|
||||||
;; TODO: s shouldn't refer to facets or fields!
|
|
||||||
#:with (τ-i τ-o τ-i/i τ-o/i τ-a) (analyze-roles #'(τ-f ...))
|
|
||||||
#:fail-unless (<: #'τ-o #'τ-c.norm)
|
|
||||||
(format "Output ~a not valid in dataspace ~a" (type->str #'τ-o) (type->str #'τ-c.norm))
|
|
||||||
#:with τ-final (mk-Actor- #'(τ-c.norm))
|
|
||||||
#:fail-unless (<: #'τ-a #'τ-final)
|
|
||||||
"Spawned actors not valid in dataspace"
|
|
||||||
#:fail-unless (project-safe? (∩ (strip-? #'τ-o) #'τ-c.norm)
|
|
||||||
#'τ-i)
|
|
||||||
"Not prepared to handle all inputs"
|
|
||||||
#:fail-unless (project-safe? #'τ-o/i #'τ-i/i)
|
|
||||||
"Not prepared to handle internal events"
|
|
||||||
--------------------------------------------------------------------------------------------
|
|
||||||
[⊢ (syndicate:spawn (syndicate:on-start s-)) (⇒ : ★/t)
|
|
||||||
(⇒ ν-s (τ-final))]]
|
|
||||||
[(spawn s) ≫
|
|
||||||
#:do [(define τc (current-communication-type))]
|
|
||||||
#:when τc
|
|
||||||
----------------------------------------
|
|
||||||
[≻ (spawn #,τc s)]])
|
|
||||||
|
|
||||||
(define-typed-syntax (dataspace τ-c:type s ...) ≫
|
|
||||||
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
|
||||||
#:mode (communication-type-mode #'τ-c.norm)
|
|
||||||
[
|
|
||||||
[⊢ s ≫ s- (⇒ ν-ep (~effs)) (⇒ ν-s (~effs τ-s ...)) (⇒ ν-f (~effs))] ...
|
|
||||||
]
|
|
||||||
#:with τ-actor (mk-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)
|
|
||||||
(⇒ ν-s ((Actor (U τ-ds-i τ-ds-o τ-relay))))])
|
|
||||||
|
|
||||||
(define-typed-syntax (set! x:id e:expr) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
|
||||||
[⊢ x ≫ x- (⇒ : (~Field τ-x:type))]
|
|
||||||
#:fail-unless (<: #'τ #'τ-x) "Ill-typed field write"
|
|
||||||
----------------------------------------------------
|
|
||||||
[⊢ (#%app- x- e-) (⇒ : ★/t)])
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Derived Forms
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-typed-syntax during
|
|
||||||
#:literals (know)
|
|
||||||
[(_ (~or (~and k (know p)) p) s ...) ≫
|
|
||||||
#:with p+ (elaborate-pattern/with-com-ty #'p)
|
|
||||||
#:with inst-p (instantiate-pattern #'p+)
|
|
||||||
#:with start-e (if (attribute k) #'know #'asserted)
|
|
||||||
#:with stop-e (if (attribute k) #'forget #'retracted)
|
|
||||||
#:with res #'(on (start-e p+)
|
|
||||||
(start-facet during-inner
|
|
||||||
(on (stop-e inst-p)
|
|
||||||
(stop during-inner))
|
|
||||||
s ...))
|
|
||||||
----------------------------------------
|
|
||||||
[≻ (on (start-e p+)
|
|
||||||
(start-facet during-inner
|
|
||||||
(on (stop-e inst-p)
|
|
||||||
(stop during-inner))
|
|
||||||
s ...))]])
|
|
||||||
|
|
||||||
(define-simple-macro (During (~or (~and K ((~literal Know) τ:type)) τ:type)
|
|
||||||
EP ...)
|
|
||||||
#:with τ/inst (instantiate-pattern-type #'τ.norm)
|
|
||||||
#:with start-e (if (attribute K) #'Know #'Asserted)
|
|
||||||
#:with stop-e (if (attribute K) #'Forget #'Retracted)
|
|
||||||
(Reacts (start-e τ)
|
|
||||||
(Role (during-inner)
|
|
||||||
(Reacts (stop-e τ/inst)
|
|
||||||
(Stop during-inner))
|
|
||||||
EP ...)))
|
|
||||||
|
|
||||||
;; 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]
|
|
||||||
;; not sure about this
|
|
||||||
[discard
|
|
||||||
#'discard]
|
|
||||||
[(~constructor-exp ctor p ...)
|
|
||||||
(define/with-syntax uctor (untyped-ctor #'ctor))
|
|
||||||
#`(ctor #,@(stx-map loop #'(p ...)))]
|
|
||||||
[_
|
|
||||||
pat])))
|
|
||||||
|
|
||||||
;; Type -> Type
|
|
||||||
;; replace occurrences of (Bind τ) with τ in a type, in much the same way
|
|
||||||
;; instantiate-pattern does for patterns
|
|
||||||
;; TODO - this is almost exactly the same as replace-bind-and-discard-with-★
|
|
||||||
(define-for-syntax (instantiate-pattern-type ty)
|
|
||||||
(syntax-parse ty
|
|
||||||
[(~Bind τ)
|
|
||||||
#'τ]
|
|
||||||
[(~U* τ ...)
|
|
||||||
(mk-U- (stx-map instantiate-pattern-type #'(τ ...)))]
|
|
||||||
[(~Any/bvs τ-cons () τ ...)
|
|
||||||
#:when (reassemblable? #'τ-cons)
|
|
||||||
(define subitems (for/list ([t (in-syntax #'(τ ...))])
|
|
||||||
(instantiate-pattern-type t)))
|
|
||||||
(reassemble-type #'τ-cons subitems)]
|
|
||||||
[_ ty]))
|
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(define-splicing-syntax-class on-add
|
|
||||||
#:attributes (expr)
|
|
||||||
(pattern (~seq #:on-add add-e)
|
|
||||||
#:attr expr #'add-e)
|
|
||||||
(pattern (~seq)
|
|
||||||
#:attr expr #'#f))
|
|
||||||
|
|
||||||
(define-splicing-syntax-class on-remove
|
|
||||||
#:attributes (expr)
|
|
||||||
(pattern (~seq #:on-remove remove-e)
|
|
||||||
#:attr expr #'remove-e)
|
|
||||||
(pattern (~seq)
|
|
||||||
#:attr expr #'#f)))
|
|
||||||
|
|
||||||
|
|
||||||
(define-typed-syntax (define/query-value x:id e0 p e
|
|
||||||
(~optional add:on-add)
|
|
||||||
(~optional remove:on-remove)) ≫
|
|
||||||
[⊢ e0 ≫ e0- (⇒ : τ)]
|
|
||||||
#:fail-unless (pure? #'e0-) "expression must be pure"
|
|
||||||
----------------------------------------
|
|
||||||
[≻ (begin (field [x τ e0-])
|
|
||||||
(on (asserted p)
|
|
||||||
#:priority *query-priority*
|
|
||||||
(set! x e)
|
|
||||||
add.expr)
|
|
||||||
(on (retracted p)
|
|
||||||
#:priority *query-priority-high*
|
|
||||||
(set! x e0-)
|
|
||||||
remove.expr))])
|
|
||||||
|
|
||||||
(define-typed-syntax (define/query-set x:id p e
|
|
||||||
(~optional add:on-add)
|
|
||||||
(~optional remove:on-remove)) ≫
|
|
||||||
#:with p+ (elaborate-pattern/with-com-ty #'p)
|
|
||||||
#:with ([y τ] ...) (pat-bindings #'p+)
|
|
||||||
;; e will be re-expanded :/
|
|
||||||
[[y ≫ y- : τ] ... ⊢ e ≫ e- ⇒ τ-e]
|
|
||||||
----------------------------------------
|
|
||||||
[≻ (begin (field [x (Set τ-e) (set)])
|
|
||||||
(on (asserted p+)
|
|
||||||
#:priority *query-priority*
|
|
||||||
(set! x (set-add (ref x) e))
|
|
||||||
add.expr)
|
|
||||||
(on (retracted p+)
|
|
||||||
#:priority *query-priority-high*
|
|
||||||
(set! x (set-remove (ref x) e))
|
|
||||||
remove.expr))])
|
|
||||||
|
|
||||||
(define-typed-syntax (define/query-hash x:id p e-key e-value
|
|
||||||
(~optional add:on-add)
|
|
||||||
(~optional remove:on-remove)) ≫
|
|
||||||
#:with p+ (elaborate-pattern/with-com-ty #'p)
|
|
||||||
#:with ([y τ] ...) (pat-bindings #'p+)
|
|
||||||
;; e-key and e-value will be re-expanded :/
|
|
||||||
;; but it's the most straightforward way to keep bindings in sync with
|
|
||||||
;; pattern
|
|
||||||
[[y ≫ y- : τ] ... ⊢ e-key ≫ e-key- ⇒ τ-key]
|
|
||||||
[[y ≫ y-- : τ] ... ⊢ e-value ≫ e-value- ⇒ τ-value]
|
|
||||||
;; TODO - this is gross, is there a better way to do this?
|
|
||||||
;; #:with e-value-- (substs #'(y- ...) #'(y-- ...) #'e-value- free-identifier=?)
|
|
||||||
;; I thought I could put e-key- and e-value-(-) in the output below, but that
|
|
||||||
;; gets their references to pattern variables out of sync with `p`
|
|
||||||
----------------------------------------
|
|
||||||
[≻ (begin (field [x (Hash τ-key τ-value) (hash)])
|
|
||||||
(on (asserted p+)
|
|
||||||
#:priority *query-priority*
|
|
||||||
(set! x (hash-set (ref x) e-key e-value))
|
|
||||||
add.expr)
|
|
||||||
(on (retracted p+)
|
|
||||||
#:priority *query-priority-high*
|
|
||||||
(set! x (hash-remove (ref x) e-key))
|
|
||||||
remove.expr))])
|
|
||||||
|
|
||||||
(define-simple-macro (on-start e ...)
|
|
||||||
(on start e ...))
|
|
||||||
|
|
||||||
(define-simple-macro (on-stop e ...)
|
|
||||||
(on stop e ...))
|
|
||||||
|
|
||||||
(define-typed-syntax define/dataflow
|
|
||||||
[(define/dataflow x:id τ:type e) ≫
|
|
||||||
[⊢ e ≫ e- (⇐ : τ)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression must be pure"
|
|
||||||
;; because the begin/dataflow body is scheduled to run at some later point,
|
|
||||||
;; the initial value is visible e.g. immediately after the define/dataflow
|
|
||||||
;; #:with place-holder (attach #'(#%datum- #f) ': #'τ.norm)
|
|
||||||
----------------------------------------
|
|
||||||
[≻ (begin (field [x τ e-])
|
|
||||||
(begin/dataflow (set! x e-)))]]
|
|
||||||
[(define/dataflow x:id e) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression must be pure"
|
|
||||||
----------------------------------------
|
|
||||||
[≻ (define/dataflow x τ e-)]])
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Expressions
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-typed-syntax (ref x:id) ≫
|
|
||||||
[⊢ x ≫ x- ⇒ (~Field τ)]
|
|
||||||
------------------------
|
|
||||||
[⊢ (#%app- x-) (⇒ : τ)])
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Ground Dataspace
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
;; n.b. this is a blocking operation, so an actor that uses this internally
|
|
||||||
;; won't necessarily terminate.
|
|
||||||
(define-typed-syntax (run-ground-dataspace τ-c:type s ...) ≫
|
|
||||||
[⊢ (dataspace τ-c s ...) ≫ ((~literal erased) ((~literal syndicate:dataspace) s- ...)) (⇒ : t)]
|
|
||||||
-----------------------------------------------------------------------------------
|
|
||||||
[⊢ (#%app- syndicate:run-ground s- ...) (⇒ : (AssertionSet τ-c))])
|
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Utilities
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-typed-syntax (print-type e) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ) (⇒ ν-ep (~effs eps ...)) (⇒ ν-f (~effs fs ...)) (⇒ ν-s (~effs ss ...))]
|
|
||||||
#:do [(pretty-display (type->strX #'τ))]
|
|
||||||
----------------------------------
|
|
||||||
[⊢ e- (⇒ : τ) (⇒ ν-ep (eps ...)) (⇒ ν-f (fs ...)) (⇒ ν-s (ss ...))])
|
|
||||||
|
|
||||||
(define-typed-syntax (print-role e) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ) (⇒ ν-ep (~effs eps ...)) (⇒ ν-f (~effs fs ...)) (⇒ ν-s (~effs ss ...))]
|
|
||||||
#:do [(for ([r (in-syntax #'(fs ...))])
|
|
||||||
(pretty-display (type->strX r)))]
|
|
||||||
----------------------------------
|
|
||||||
[⊢ e- (⇒ : τ) (⇒ ν-ep (eps ...)) (⇒ ν-f (fs ...)) (⇒ ν-s (ss ...))])
|
|
||||||
|
|
||||||
;; this is mainly for testing
|
|
||||||
(define-typed-syntax (role-strings e) ≫
|
|
||||||
[⊢ e ≫ e- (⇒ : τ) (⇒ ν-f (~effs fs ...))]
|
|
||||||
#:with (s ...) (for/list ([r (in-syntax #'(fs ...))])
|
|
||||||
(type->strX r))
|
|
||||||
----------------------------------------
|
|
||||||
[⊢ (#%app- list- (#%datum- . s) ...) (⇒ : (List String))])
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Tests
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(check-type (spawn (U (Message (Tuple String Int))
|
|
||||||
(Observe (Tuple String ★/t)))
|
|
||||||
(start-facet echo
|
|
||||||
(on (message (tuple "ping" $x))
|
|
||||||
(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)))))))
|
|
||||||
|
|
||||||
;; 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))
|
|
|
@ -0,0 +1,778 @@
|
||||||
|
#lang scribble/manual
|
||||||
|
|
||||||
|
@(require (for-label (only-in racket struct)
|
||||||
|
typed/syndicate/roles)
|
||||||
|
(prefix-in racket: (for-label racket))
|
||||||
|
(prefix-in untyped: (for-label syndicate/actor)))
|
||||||
|
|
||||||
|
@title{Typed Syndicate}
|
||||||
|
|
||||||
|
|
||||||
|
@defmodule[typed/syndicate/roles]
|
||||||
|
|
||||||
|
@section{Overview}
|
||||||
|
|
||||||
|
@section{Types}
|
||||||
|
|
||||||
|
@deftogether[(@defidform[Int]
|
||||||
|
@defidform[Bool]
|
||||||
|
@defidform[String]
|
||||||
|
@defidform[ByteString]
|
||||||
|
@defidform[Symbol])]{
|
||||||
|
Base types.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(U type ...)]{
|
||||||
|
The type representing the union of @racket[type ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defidform[⊥]{
|
||||||
|
An alias for @racket[(U)].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defidform[★/t]{
|
||||||
|
The type representing any possible assertion, and, in an @racket[AssertionSet],
|
||||||
|
the possibility for an infinite set of assertions.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defidform[Discard]{
|
||||||
|
The type of @racket[_] patterns.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Bind type)]{
|
||||||
|
The type of @racket[$] patterns.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defidform[FacetName]{
|
||||||
|
The type associated with identifiers bound by @racket[start-facet].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Role (x) type ...)]{
|
||||||
|
The type of a facet named @racket[x] and endpoints described by @racket[type
|
||||||
|
...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Stop X type ...)]{
|
||||||
|
The type of a @racket[stop] action.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Field type)]{
|
||||||
|
The type of a field containing values of @racket[type].
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@defform[(Shares type)]{
|
||||||
|
The type of an @racket[assert] endpoint.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (OnStart OnStop Asserted Retracted)
|
||||||
|
(Reacts EventDesc type ...)
|
||||||
|
#:grammar
|
||||||
|
[(EventDesc (code:line OnStart)
|
||||||
|
(code:line OnStart)
|
||||||
|
(code:line (Asserted event-type))
|
||||||
|
(code:line (Retracted event-type)))]]{
|
||||||
|
The type of a @racket[on] endpoint that reacts to events described by
|
||||||
|
@racket[EventDesc] with the behavior given by @racket[type ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(@defidform[OnStart]
|
||||||
|
@defidform[OnStop]
|
||||||
|
@defform[(Asserted type)]
|
||||||
|
@defform[(Retracted type)])]{
|
||||||
|
See @racket[Reacts].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Actor type)]{
|
||||||
|
The type of an actor that operates in a dataspace with a certain communication
|
||||||
|
@racket[type].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(ActorWithRole comm-type behavior-type)]{
|
||||||
|
An @racket[Actor] type with the additional @racket[behavior-type] describing the
|
||||||
|
actor's behavior in terms of a @racket[Role].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Sends type)]{
|
||||||
|
The type of a @racket[send!] action.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Realize type)]{
|
||||||
|
The type of a @racket[realize!] action.
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(@defform[(Branch type ...)]
|
||||||
|
@defform[(Effs type ...)])]{
|
||||||
|
Types that may arise in descriptions in @racket[Role] types due to branching and
|
||||||
|
sequencing.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(Tuple type ...)]{
|
||||||
|
The type of @racket[tuple] expressions.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defidform[Unit]{
|
||||||
|
An alias for @racket[(Tuple)].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(AssertionSet type)]{
|
||||||
|
The type for a set of assertions of a certain @racket[type]. Note that these are
|
||||||
|
not interoperable with the general purpose @racket[set] data structures.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(∀ (X ...) type)]{
|
||||||
|
Universal quantification over types.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (Computation Value Endpoints Roles Spawns)
|
||||||
|
(→ type ... (Computation (Value result-type)
|
||||||
|
(Endpoints ep-type ...)
|
||||||
|
(Roles role-type ...)
|
||||||
|
(Spawns spawn-type ...)))]{
|
||||||
|
The type of a function with parameters @racket[type ...] that returns @racket[result-type]. The type includes the effects of any actions performed by the function:
|
||||||
|
@itemlist[
|
||||||
|
@item{@racket[Endpoints]: includes any endpoint installation effects, such as from @racket[assert] and @racket[on].}
|
||||||
|
@item{@racket[Roles]: includes any script action effects, such as from @racket[start-facet], @racket[stop], and @racket[send!].}
|
||||||
|
@item{@racket[Spawns]: includes descriptions of any @racket[spawn] actions.}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(→fn type-in ... type-out)]{
|
||||||
|
Shorthand for a @racket[→] type with no effects.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(proc maybe-quantifiers type-in ... maybe-arrow type-out
|
||||||
|
maybe-endpoints
|
||||||
|
maybe-roles
|
||||||
|
maybe-spawns)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-quantifiers (code:line)
|
||||||
|
(code:line #:forall (X ...)))
|
||||||
|
(maybe-arrow (code:line)
|
||||||
|
(code:line →)
|
||||||
|
(code:line ->))
|
||||||
|
(maybe-endpoints (code:line)
|
||||||
|
(code:line #:endpoints (e ...)))
|
||||||
|
(maybe-roles (code:line)
|
||||||
|
(code:line #:roles (r ...)))
|
||||||
|
(maybe-spawns (code:line)
|
||||||
|
(code:line #:spawns (s ...)))]]{
|
||||||
|
A more convenient notation for writing (potentially polymorphic) function types
|
||||||
|
with effects. Shorthand for @racket[(∀ (X ...) (→ type-in ... (Computation
|
||||||
|
(Value type-out) (Endpoints e ...) (Roles r ...) (Spawns s ...))))].
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(@defform[(Computation type ...)]
|
||||||
|
@defform[(Value type)]
|
||||||
|
@defform[(Endpoints type)]
|
||||||
|
@defform[(Roles type)]
|
||||||
|
@defform[(Spawns type)])]{
|
||||||
|
See @racket[→].
|
||||||
|
}
|
||||||
|
|
||||||
|
@section{User Defined Types}
|
||||||
|
|
||||||
|
@defform*[[(define-type-alias id type)
|
||||||
|
(define-type-alias (ty-cons-id arg-id ...) type)]]{
|
||||||
|
Define @racket[id] to be the same as @racket[type], or create a type constructor
|
||||||
|
@racket[(ty-cons-id ty ...)] whose meaning is @racket[type] with references to
|
||||||
|
@racket[arg-id ...] replaced by @racket[ty ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define-constructor (ctor-id slot-id ...)
|
||||||
|
maybe-type-ctor
|
||||||
|
maybe-alias ...)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-type-ctor (code:line)
|
||||||
|
(code:line #:type-constructor type-ctor-id))
|
||||||
|
(maybe-alias (code:line)
|
||||||
|
(code:line #:with alias alias-body))]]{
|
||||||
|
Defines a container analagous to a prefab @racket[struct]. Includes accessor
|
||||||
|
functions for each @racket[slot-id]. (But not, presently, a predicate function).
|
||||||
|
|
||||||
|
When a @racket[type-ctor-id] is provided, the type of such structures is
|
||||||
|
@racket[(type-ctor-id type ...)], where each @racket[type] describes the value
|
||||||
|
of the corresponding slot. When not provided, the type constructor is named by
|
||||||
|
appending @racket["/t"] to @racket[ctor-id].
|
||||||
|
|
||||||
|
Each @racket[alias] and @racket[alias-body] creates an instance of
|
||||||
|
@racket[define-type-alias].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(define-constructor* (ctor-id : type-ctor-id slot-id ...)
|
||||||
|
maybe-alias ...)]{
|
||||||
|
An abbreviated form of @racket[define-constructor].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(assertion-struct ctor-id : type-ctor-id (slot-id ...))]{
|
||||||
|
An abbreviated form of @racket[define-constructor].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(message-struct ctor-id : type-ctor-id (slot-id ...))]{
|
||||||
|
An abbreviated form of @racket[define-constructor].
|
||||||
|
}
|
||||||
|
|
||||||
|
@section{Actor Forms}
|
||||||
|
|
||||||
|
@defform[(run-ground-dataspace type expr ...)]{
|
||||||
|
Starts a ground, i.e. main, dataspace of the program, with the given
|
||||||
|
communication @racket[type] and initial actors spawned by @racket[expr ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(spawn maybe-type s)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-type (code:line)
|
||||||
|
(code:line type))]]{
|
||||||
|
Spawns an actor with behavior given by @racket[s]. The @racket[type] gives the
|
||||||
|
communication type of the enclosing dataspace. When absent, @racket[type] is
|
||||||
|
supplied by the nearest lexically enclosing @racket[spawn] or @racket[dataspace]
|
||||||
|
form, if any exist.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(dataspace type expr ...)]{
|
||||||
|
Spawns a dataspace with communication type @racket[type] as a child of the
|
||||||
|
dataspace enclosing the executing actor. The script @racket[expr ...] spawns the
|
||||||
|
initial actors of the new dataspace.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(start-facet id maybe-spec expr ...+)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-spec (code:line)
|
||||||
|
(code:line #:implements type)
|
||||||
|
(code:line #:includes-behavior type))]]{
|
||||||
|
Start a facet with name @racket[id] and endpoints installed through the
|
||||||
|
evaluation of @racket[expr ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(stop id expr ...)]{
|
||||||
|
Terminate the facet @racket[id] with continuation script @racket[expr ...]. Any
|
||||||
|
facets started by the continuation script survive the termination of facet
|
||||||
|
@racket[id].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (start stop message asserted retracted _ $)
|
||||||
|
(on event-description body ...+)
|
||||||
|
#:grammar
|
||||||
|
[(event-description (code:line start)
|
||||||
|
(code:line stop)
|
||||||
|
(code:line (message pattern))
|
||||||
|
(code:line (asserted pattern))
|
||||||
|
(code:line (retracted pattern)))
|
||||||
|
(pattern (code:line _)
|
||||||
|
(code:line ($ id type))
|
||||||
|
(code:line ($ id))
|
||||||
|
(code:line $id)
|
||||||
|
(code:line $id:type)
|
||||||
|
(code:line (ctor pattern ...))
|
||||||
|
(code:line expr))]]{
|
||||||
|
Creates an event handler endpoint that responds to the event specified by
|
||||||
|
@racket[event-description]. Executes the @racket[body ...] for each matching
|
||||||
|
event, with any pattern variables bound to their matched value.
|
||||||
|
|
||||||
|
Patterns have the following meanings:
|
||||||
|
@itemlist[
|
||||||
|
@item{@racket[_] matches anything.}
|
||||||
|
|
||||||
|
@item{@racket[($ id type)] matches any value and binds it to @racket[id] with
|
||||||
|
assumed type @racket[type].}
|
||||||
|
|
||||||
|
@item{@racket[($ id)] is like @racket[($ id type)], but attempts to use the
|
||||||
|
current communication type to fill in the @racket[type] of potential matches.
|
||||||
|
May raise an error if no suitable communication type is in scope.}
|
||||||
|
|
||||||
|
@item{@racket[(? pred pattern)] matches values where @racket[(pred val)] is not
|
||||||
|
@racket[#f] and that match @racket[pattern].}
|
||||||
|
|
||||||
|
@item{@racket[$id:type] is shorthand for @racket[($ id type)].}
|
||||||
|
|
||||||
|
@item{@racket[$id] is shorthand for @racket[($ id)].}
|
||||||
|
|
||||||
|
@item{@racket[(ctor pat ...)] matches values built by applying the constructor
|
||||||
|
@racket[ctor] to values matching @racket[pat ...]. @racket[ctor] is usually
|
||||||
|
a @racket[struct] name.}
|
||||||
|
|
||||||
|
@item{@racket[expr] patterns match values that are @racket[equal?] to
|
||||||
|
@racket[expr].}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(on-start expr ...+)]{
|
||||||
|
Shorthand for @racket[(on start expr ...)].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(on-stop expr ...+)]{
|
||||||
|
Shorthand for @racket[(on stop expr ...)].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(assert expr)]{
|
||||||
|
Creates an assertion endpoint with the value of @racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(know expr)]{
|
||||||
|
Creates an internal assertion endpoint with the value of @racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(send! expr)]{
|
||||||
|
Broadcast a dataspace message with the value of @racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(realize! expr)]{
|
||||||
|
Broadcast an actor-internal message with the value of @racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(field [id maybe-type expr] ...)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-type (code:line)
|
||||||
|
(code:line type)
|
||||||
|
(code:line : type))]]{
|
||||||
|
Defines fields of type @racket[type] with names @racket[id] and initial values
|
||||||
|
@racket[expr]. If @racket[type] is not provided, the type of the initial
|
||||||
|
expression is used as the type of the field.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(ref id)]{
|
||||||
|
Reference the @racket[field] named @racket[id].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(set! id expr)]{
|
||||||
|
Update the value the @racket[field] named @racket[id].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(begin/dataflow expr ...+)]{
|
||||||
|
Evaluate and perform the script @racket[expr ...], and then again each time a
|
||||||
|
field referenced by the script updates.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(during pattern expr ...+)]{
|
||||||
|
Engage in behavior for the duration of a matching assertion. The syntax of
|
||||||
|
@racket[pattern] is the same as described by @racket[on].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(during/spawn pattern expr ...+)]{
|
||||||
|
Like @racket[during], but spawns an actor for the behavior @racket[expr ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/query-value name absent-expr pattern expr
|
||||||
|
maybe-on-add
|
||||||
|
maybe-on-remove)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-on-add (code:line)
|
||||||
|
(code:line #:on-add on-add-expr))
|
||||||
|
(maybe-on-remove (code:line)
|
||||||
|
(code:line #:on-remove on-remove-expr))]]{
|
||||||
|
Equivalent to the untyped @racket[untyped:define/query-value]. The
|
||||||
|
@racket[on-add-expr] and @racket[on-remove-expr], when given, execute after
|
||||||
|
@racket[name] has been updated.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/query-set name pattern expr
|
||||||
|
maybe-on-add
|
||||||
|
maybe-on-remove)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-on-add (code:line)
|
||||||
|
(code:line #:on-add on-add-expr))
|
||||||
|
(maybe-on-remove (code:line)
|
||||||
|
(code:line #:on-remove on-remove-expr))]]{
|
||||||
|
Equivalent to the untyped @racket[untyped:define/query-set].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/query-hash name pattern key-expr value-expr
|
||||||
|
maybe-on-add
|
||||||
|
maybe-on-remove)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-on-add (code:line)
|
||||||
|
(code:line #:on-add on-add-expr))
|
||||||
|
(maybe-on-remove (code:line)
|
||||||
|
(code:line #:on-remove on-remove-expr))]]{
|
||||||
|
Equivalent to the untyped @racket[untyped:define/query-hash].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define/dataflow name maybe-type expr)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-type (code:line)
|
||||||
|
(code:line type))]]{
|
||||||
|
Define a @racket[field] named @racket[name], whose value is reevaluated to the
|
||||||
|
result of @racket[expr] each time any referenced field changes. When
|
||||||
|
@racket[type] is not supplied, the field has the type of the given
|
||||||
|
@racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@section{Expressions}
|
||||||
|
|
||||||
|
@defform*[#:literals (:)
|
||||||
|
[(ann expr : type)
|
||||||
|
(ann expr type)]]{
|
||||||
|
Ensure that @racket[expr] has the given @racket[type].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(if test-expr then-expr else-expr)]{
|
||||||
|
The same as Racket's @racket[racket:if].
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(@defform[(cond [test-expr body-expr ...+] ...+)]
|
||||||
|
@defthing[else Bool #:value #t])]{
|
||||||
|
Like Racket's @racket[racket:cond].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(when test-expr expr)]{
|
||||||
|
Like Racket's @racket[racket:when], but results in @racket[#f] when
|
||||||
|
@racket[test-expr] is @racket[#f].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(unless test-expr expr)]{
|
||||||
|
Like Racket's @racket[racket:unless], but results in @racket[#f] when
|
||||||
|
@racket[test-expr] is @racket[#f].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(let ([id expr] ...) body ...+)]{
|
||||||
|
The same as Racket's @racket[racket:let].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(let* ([id expr] ...) body ...+)]{
|
||||||
|
The same as Racket's @racket[racket:let*].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(lambda ([x opt-: type] ...) expr ...+)
|
||||||
|
#:grammar
|
||||||
|
[(opt-: (code:line)
|
||||||
|
(code:line :))]]{
|
||||||
|
Constructsa an anonymous function.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defidform[λ]{Synonym for @racket[lambda].}
|
||||||
|
|
||||||
|
@defform[(Λ (X ...) expr)]{
|
||||||
|
Parametric abstraction over type variables @racket[X ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(inst expr type ...)]{
|
||||||
|
Instantiates the type variables @racket[X ...] with @racket[type ...], where
|
||||||
|
@racket[expr] has type @racket[(∀ (X ...) t)].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform*[#:literals (: → -> ∀)
|
||||||
|
[(define id : type expr)
|
||||||
|
(define id expr)
|
||||||
|
(define (id [arg-id opt-: arg-type] ... opt-res-ty) expr ...+)
|
||||||
|
(define (∀ (X ...) (id [arg-id opt-: arg-type] ... opt-res-ty)) expr ...+)]
|
||||||
|
#:grammar
|
||||||
|
[(opt-: (code:line) (code:line :))
|
||||||
|
(opt-res-ty (code:line)
|
||||||
|
(code:line arr res-type))
|
||||||
|
(arr (code:line →) (code:line ->))]]{
|
||||||
|
Define a constant or a (potentially polymorphic) function. Note that the
|
||||||
|
function name @racket[id] is @emph{not} bound in the body.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(define-tuple (id ...) expr)]{
|
||||||
|
Define @racket[id ...] to each of the slots of the tuple produced by
|
||||||
|
@racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(match-define pattern expr)]{
|
||||||
|
Define the binders of @racket[pattern] to the matching values of @racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(begin expr ...+)]{
|
||||||
|
Sequencing form whose value and type is that of the final @racket[expr].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(block expr ...+)]{
|
||||||
|
Like @racket[begin], but also introduces a definition context for its body.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(match expr [pattern body-expr ...+] ...+)]{
|
||||||
|
Like Racket's @racket[racket:match] but with the pattern syntax described by
|
||||||
|
@racket[on].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(tuple expr ...)]{
|
||||||
|
Constructs a tuple of arbitrary arity.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(select i expr)]{
|
||||||
|
Extract the @racket[i]th element of a @racket[tuple].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defthing[unit Unit #:value (tuple)]
|
||||||
|
|
||||||
|
@defform[(error format-expr arg-expr ...)]{
|
||||||
|
Raises an exception using @racket[format-expr] as a format string together with
|
||||||
|
@racket[arg-expr ...].
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defthing[+ (→fn Int Int Int)]
|
||||||
|
@defthing[- (→fn Int Int Int)]
|
||||||
|
@defthing[* (→fn Int Int Int)]
|
||||||
|
@defthing[< (→fn Int Int Bool)]
|
||||||
|
@defthing[> (→fn Int Int Bool)]
|
||||||
|
@defthing[<= (→fn Int Int Bool)]
|
||||||
|
@defthing[>= (→fn Int Int Bool)]
|
||||||
|
@defthing[= (→fn Int Int Bool)]
|
||||||
|
@defthing[even? (→fn Int Bool)]
|
||||||
|
@defthing[odd? (→fn Int Bool)]
|
||||||
|
@defthing[add1 (→fn Int Int)]
|
||||||
|
@defthing[sub1 (→fn Int Int)]
|
||||||
|
@defthing[max (→fn Int Int Int)]
|
||||||
|
@defthing[min (→fn Int Int Int)]
|
||||||
|
@defthing[zero? (→fn Int Bool)]
|
||||||
|
@defthing[positive? (→fn Int Bool)]
|
||||||
|
@defthing[negative? (→fn Int Bool)]
|
||||||
|
@defthing[current-inexact-milleseconds? (→fn Int)]
|
||||||
|
@defthing[string=? (→fn String String Bool)]
|
||||||
|
@defthing[bytes->string/utf-8 (→fn ByteString String)]
|
||||||
|
@defthing[string->bytes/utf-8 (→fn String ByteString)]
|
||||||
|
@defthing[gensym (→fn Symbol Symbol)]
|
||||||
|
@defthing[symbol->string (→fn Symbol String)]
|
||||||
|
@defthing[string->symbol (→fn String Symbol)]
|
||||||
|
@defthing[not (→fn Bool Bool)]
|
||||||
|
@defform[(/ e1 e2)]
|
||||||
|
@defform[(and e ...)]
|
||||||
|
@defform[(or e ...)]
|
||||||
|
@defform[(equal? e1 e2)]
|
||||||
|
@defform[(displayln e)]
|
||||||
|
@defform[(printf fmt-expr val-expr ...)]
|
||||||
|
@defform[(~a e ...)]
|
||||||
|
)]{
|
||||||
|
Primitive operations imported from Racket.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(for/fold ([acc-id maybe-:ty acc-expr] ...+)
|
||||||
|
(for-clause ...)
|
||||||
|
body-expr ...+)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-:ty (code:line)
|
||||||
|
(code:line : acc-type))
|
||||||
|
(for-clause (code:line [id seq-expr])
|
||||||
|
(code:line [id : type seq-expr])
|
||||||
|
(code:line [(k-id v-id) hash-expr])
|
||||||
|
(code:line #:when test-expr)
|
||||||
|
(code:line #:unless test-expr)
|
||||||
|
(code:line #:break test-expr))]]{
|
||||||
|
Similar to Racket's @racket[racket:for/fold].
|
||||||
|
|
||||||
|
When more than one @racket[acc-id] is used, the body of the loop must evaluate
|
||||||
|
to a @racket[tuple] with one value for each accumulator, with the final tuple
|
||||||
|
also being the result of the entire expression.
|
||||||
|
|
||||||
|
Each @racket[seq-expr] should be of type @racket[Sequence], though expressions
|
||||||
|
of type @racket[List] and @racket[Set] are automatically converted.
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defform[(for/list (for-clause ...) body ...+)]
|
||||||
|
@defform[(for/set (for-clause ...) body ...+)]
|
||||||
|
@defform[(for/sum (for-clause ...) body ...+)]
|
||||||
|
@defform[(for (for-clause ...) body ...+)]
|
||||||
|
@defform[(for/first (for-clause ...) body ...+)]
|
||||||
|
)]{
|
||||||
|
Like their Racket counterparts. See @racket[for/fold] for the description of
|
||||||
|
@racket[for-clause].
|
||||||
|
|
||||||
|
Unlike @racket[racket:for/first], @racket[for/first] returns a @racket[Maybe]
|
||||||
|
value to indicate success/failure.
|
||||||
|
}
|
||||||
|
|
||||||
|
@section{Require & Provide}
|
||||||
|
|
||||||
|
@defform[(struct-out ctor-id)]{
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Requiring From Outside Typed Syndicate}
|
||||||
|
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(require/typed lib clause ...)
|
||||||
|
#:grammar
|
||||||
|
[(clause (code:line [id : type])
|
||||||
|
(code:line opaque))
|
||||||
|
(opaque (code:line [#:opaque type-name])
|
||||||
|
(code:line [#:opaque type-name #:arity op arity-nat]))
|
||||||
|
(opaque (code:line =) (code:line >) (code:line >=))]]{
|
||||||
|
Import and assign types to bindings from outside Typed Syndicate.
|
||||||
|
|
||||||
|
Note that @emph{unlike} Typed Racket, Typed Syndicate does not attach contracts
|
||||||
|
to imported bindings.
|
||||||
|
|
||||||
|
An @racket[#:opaque] declaration defines a type @racket[type-name] (or, in the
|
||||||
|
@racket[#:arity] case, a type constructor) that may be used to describe imports
|
||||||
|
but otherwise has no other operations.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defform[(require-struct ctor-id #:as ty-ctor-id #:from lib maybe-omit-accs)
|
||||||
|
#:grammar
|
||||||
|
[(maybe-omit-accs (code:line)
|
||||||
|
(code:line #:omit-accs))]]{
|
||||||
|
Import a Racket @racket[struct] named @racket[ctor-id] and create a type
|
||||||
|
constructor @racket[ty-ctor-id] for its instances.
|
||||||
|
|
||||||
|
Unless @racket[#:omit-accs] is specified, defines the accessor functions for the
|
||||||
|
struct.
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@section{Builtin Data Structures}
|
||||||
|
|
||||||
|
@deftogether[(@defstruct[observe ([claim any?]) #:omit-constructor]
|
||||||
|
@defform[(Observe type)])]{
|
||||||
|
Constructs an assertion of interest.
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(@defstruct[inbound ([assertion any?]) #:omit-constructor]
|
||||||
|
@defform[(Inbound type)])]{
|
||||||
|
Constructor for an assertion inbound from an outer dataspace.
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(@defstruct[outbound ([assertion any?]) #:omit-constructor]
|
||||||
|
@defform[(Outbound type)])]{
|
||||||
|
Constructor for an assertion outbound to an outer dataspace.
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(@defstruct[message ([body any?]) #:omit-constructor]
|
||||||
|
@defform[(Message type)])]{
|
||||||
|
Constructor for a broadcast message.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Lists}
|
||||||
|
|
||||||
|
@defform[(List type)]{
|
||||||
|
The type for @racket[cons] lists whose elements are of type @racket[type].
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defthing[empty (List ⊥)]
|
||||||
|
@defthing[empty? (∀ (X) (→fn (List X) Bool))]
|
||||||
|
@defthing[cons (∀ (X) (→fn X (List X) (List X)))]
|
||||||
|
@defthing[cons? (∀ (X) (→fn X (List X) Bool))]
|
||||||
|
@defthing[first (∀ (X) (→fn (List X) X))]
|
||||||
|
@defthing[second (∀ (X) (→fn (List X) X))]
|
||||||
|
@defthing[rest (∀ (X) (→fn (List X) (List X)))]
|
||||||
|
@defthing[member? (∀ (X) (→fn X (List X) Bool))]
|
||||||
|
@defthing[reverse (∀ (X) (→fn (List X) (List X)))]
|
||||||
|
@defthing[partition (∀ (X) (→fn (List X) (→fn X Bool) (List X)))]
|
||||||
|
@defthing[map (∀ (X Y) (→fn (→fn X Y) (List X) (List Y)))]
|
||||||
|
@defthing[argmax (∀ (X) (→fn (→fn X Int) (List X) X))]
|
||||||
|
@defthing[argmin (∀ (X) (→fn (→fn X Int) (List X) X))]
|
||||||
|
@defthing[remove (∀ (X) (→fn X (List X) (List X)))]
|
||||||
|
@defthing[length (∀ (X) (→fn (List X) Int))]
|
||||||
|
@defform[(list e ...)]
|
||||||
|
)]{
|
||||||
|
Like their Racket counterparts.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Sets}
|
||||||
|
|
||||||
|
@defform[(Set type)]{
|
||||||
|
The type for sets whose elements are of type @racket[type].
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defform[(set e ...)]
|
||||||
|
@defform[(set-union st ...+)]
|
||||||
|
@defform[(set-intersect st ...+)]
|
||||||
|
@defform[(set-subtract st ...+)]
|
||||||
|
@defthing[set-first (∀ (X) (→fn (Set X) X))]
|
||||||
|
@defthing[set-empty? (∀ (X) (→fn (Set X) Bool))]
|
||||||
|
@defthing[set-count (∀ (X) (→fn (Set X) Int))]
|
||||||
|
@defthing[set-add (∀ (X) (→fn (Set X) X (Set X)))]
|
||||||
|
@defthing[set-remove (∀ (X) (→fn (Set X) X (Set X)))]
|
||||||
|
@defthing[set-member? (∀ (X) (→fn (Set X) X Bool))]
|
||||||
|
@defthing[list->set (∀ (X) (→fn (List X) (Set X)))]
|
||||||
|
@defthing[set->list (∀ (X) (→fn (Set X) (List X)))]
|
||||||
|
)]{
|
||||||
|
Like their Racket counterparts.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Hashes}
|
||||||
|
|
||||||
|
@defform[(Hash key-type value-type)]{
|
||||||
|
The type for key/value hash tables.
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defform[(hash key val ... ...)]
|
||||||
|
@defthing[hash-set (∀ (K V) (→fn (Hash K V) K V (Hash K V)))]
|
||||||
|
@defthing[hash-ref (∀ (K V) (→fn (Hash K V) K V))]
|
||||||
|
@defthing[hash-ref/failure (∀ (K V) (→fn (Hash K V) K V V))]
|
||||||
|
@defthing[hash-empty? (∀ (K V) (→fn (Hash K V) Bool))]
|
||||||
|
@defthing[hash-has-key? (∀ (K V) (→fn (Hash K V) K Bool))]
|
||||||
|
@defthing[hash-count (∀ (K V) (→fn (Hash K V) Int))]
|
||||||
|
@defthing[hash-update (∀ (K V) (→fn (Hash K V) K (→fn V V) (Hash K V)))]
|
||||||
|
@defthing[hash-update/failure (∀ (K V) (→fn (Hash K V) K (→fn V V) V (Hash K V)))]
|
||||||
|
@defthing[hash-remove (∀ (K V) (→fn (Hash K V) K (Hash K V)))]
|
||||||
|
@defthing[hash-map (∀ (K V R) (→fn (Hash K V) (→fn K V R) (List R)))]
|
||||||
|
@defthing[hash-keys (∀ (K V) (→fn (Hash K V) (List K)))]
|
||||||
|
@defthing[hash-values (∀ (K V) (→fn (Hash K V) (List V)))]
|
||||||
|
@defthing[hash-union (∀ (K1 V1 K2 V2) (→fn (Hash K1 V1) (Hash K2 V2) (Hash (U K1 K2) (U V1 V2))))]
|
||||||
|
@defthing[hash-union/combine (∀ (K V) (→fn (Hash K V) (Hash K V) (→fn V V V) (Hash K V)))]
|
||||||
|
@defthing[hash-keys-subset? (∀ (K1 V1 K2 V2) (→fn (Hash K1 V1) (Hash K2 V2) Bool))]
|
||||||
|
)]{
|
||||||
|
Like their Racket counterparts. The /failure and /combine suffixes are in place
|
||||||
|
of keyword arguments, which Typed Syndicate does not presently support.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Sequences}
|
||||||
|
|
||||||
|
@defform[(Sequence type)]{
|
||||||
|
The type for a sequence of @racket[type] values.
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defthing[empty-sequence (Sequence ⊥)]
|
||||||
|
@defthing[sequence->list (∀ (X) (→fn (Sequence X) (List X)))]
|
||||||
|
@defthing[sequence-length (∀ (X) (→fn (Sequence X) Int))]
|
||||||
|
@defthing[sequence-ref (∀ (X) (→fn (Sequence X) Int Int))]
|
||||||
|
@defthing[sequence-tail (∀ (X) (→fn (Sequence X) Int (Sequence X)))]
|
||||||
|
@defthing[sequence-append (∀ (X) (→fn (Sequence X) (Sequence X) (Sequence X)))]
|
||||||
|
@defthing[sequence-map (∀ (A B) (→fn (→fn A B) (Sequence A) (Sequence B)))]
|
||||||
|
@defthing[sequence-andmap (∀ (X) (→fn (→fn X Bool) (Sequence X) Bool))]
|
||||||
|
@defthing[sequence-ormap (∀ (X) (→fn (→fn X Bool) (Sequence X) Bool))]
|
||||||
|
@defthing[sequence-fold (∀ (A B) (→fn (→fn A B A) (Sequence B) A))]
|
||||||
|
@defthing[sequence-count (∀ (X) (→fn (→fn X Bool) (Sequence X) Int))]
|
||||||
|
@defthing[sequence-filter (∀ (X) (→fn (→fn X Bool) (Sequence X) (Sequence X)))]
|
||||||
|
@defthing[sequence-add-between (∀ (X) (→fn (Sequence X) X (Sequence X)))]
|
||||||
|
@defthing[in-list (∀ (X) (→fn (List X) (Sequence X)))]
|
||||||
|
@defthing[in-hash-keys (∀ (K V) (→fn (Hash K V) (Sequence K)))]
|
||||||
|
@defthing[in-hash-values (∀ (K V) (→fn (Hash K V) (Sequence V)))]
|
||||||
|
@defthing[in-range (→fn Int (Sequence Int))]
|
||||||
|
@defthing[in-set (∀ (X) (→fn (Set X) (Sequence X)))]
|
||||||
|
)]{
|
||||||
|
Like their Racket counterparts.
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Maybe}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defidform[None]
|
||||||
|
@defthing[none None]
|
||||||
|
@defstruct[some ([v any?]) #:omit-constructor]
|
||||||
|
@defform[(Some type)]
|
||||||
|
@defform[(Maybe type)]
|
||||||
|
)]{
|
||||||
|
@racket[(Maybe type)] is an alias for @racket[(U None (Some type))].
|
||||||
|
}
|
||||||
|
|
||||||
|
@subsection{Either}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defstruct[left ([v any?]) #:omit-constructor]
|
||||||
|
@defform[(Left type)]
|
||||||
|
@defstruct[right ([v any?]) #:omit-constructor]
|
||||||
|
@defform[(Right type)]
|
||||||
|
@defform[(Either left-type right-type)]
|
||||||
|
)]{
|
||||||
|
@racket[(Either left-type right-type)] is an alias for @racket[(U (Left
|
||||||
|
left-type) (Right right-type))].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defthing[partition/either (∀ (X Y Z) (→fn (List X) (→fn X (Either Y Z)) (Tuple (List Y) (List Z))))]{
|
||||||
|
Partition a list based on a function that returns an @racket[Either] value.
|
||||||
|
}
|
||||||
|
|
||||||
|
@section{Behavioral Checking}
|
File diff suppressed because it is too large
Load Diff
|
@ -17,6 +17,8 @@
|
||||||
error
|
error
|
||||||
define-tuple
|
define-tuple
|
||||||
match-define
|
match-define
|
||||||
|
mk-tuple
|
||||||
|
tuple-select
|
||||||
(for-syntax (all-defined-out)))
|
(for-syntax (all-defined-out)))
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
|
@ -29,12 +31,12 @@
|
||||||
|
|
||||||
(define-typed-syntax (bind x:id τ:type) ≫
|
(define-typed-syntax (bind x:id τ:type) ≫
|
||||||
----------------------------------------
|
----------------------------------------
|
||||||
[⊢ (error- 'bind "escaped") (⇒ : (Bind τ))])
|
[⊢ (#%app- error- 'bind "escaped") (⇒ : (Bind τ))])
|
||||||
|
|
||||||
(define-typed-syntax discard
|
(define-typed-syntax discard
|
||||||
[_ ≫
|
[_ ≫
|
||||||
--------------------
|
--------------------
|
||||||
[⊢ (error- 'discard "escaped") (⇒ : Discard)]])
|
[⊢ (#%app- error- 'discard "escaped") (⇒ : Discard)]])
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Core-ish forms
|
;; Core-ish forms
|
||||||
|
@ -42,39 +44,30 @@
|
||||||
|
|
||||||
;; copied from stlc
|
;; copied from stlc
|
||||||
(define-typed-syntax (ann e (~optional (~datum :)) τ:type) ≫
|
(define-typed-syntax (ann e (~optional (~datum :)) τ:type) ≫
|
||||||
[⊢ e ≫ e- (⇐ : τ.norm)]
|
[⊢ e ≫ e- (⇐ : τ.norm) (⇒ ν (~effs eff ...))]
|
||||||
#:fail-unless (pure? #'e-) "expression must be pure"
|
|
||||||
------------------------------------------------
|
------------------------------------------------
|
||||||
[⊢ e- (⇒ : τ.norm) ])
|
[⊢ e- (⇒ : τ.norm) (⇒ ν (eff ...))])
|
||||||
|
|
||||||
;; copied from ext-stlc
|
;; copied from ext-stlc
|
||||||
(define-typed-syntax if
|
(define-typed-syntax if
|
||||||
[(_ e_tst e1 e2) ⇐ τ-expected ≫
|
[(_ e_tst e1 e2) ⇐ τ-expected ≫
|
||||||
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
||||||
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
||||||
[⊢ e1 ≫ e1- (⇐ : τ-expected)
|
[⊢ e1 ≫ e1- (⇐ : τ-expected) (⇒ ν (~effs eff1 ...))]
|
||||||
(⇒ ν-ep (~effs eps1 ...)) (⇒ ν-f (~effs fs1 ...)) (⇒ ν-s (~effs ss1 ...))]
|
[⊢ e2 ≫ e2- (⇐ : τ-expected) (⇒ ν (~effs eff2 ...))]
|
||||||
[⊢ e2 ≫ e2- (⇐ : τ-expected)
|
|
||||||
(⇒ ν-ep (~effs eps2 ...)) (⇒ ν-f (~effs fs2 ...)) (⇒ ν-s (~effs ss2 ...))]
|
|
||||||
--------
|
--------
|
||||||
[⊢ (if- e_tst- e1- e2-)
|
[⊢ (if- e_tst- e1- e2-)
|
||||||
(⇒ : τ-expected)
|
(⇒ : τ-expected)
|
||||||
(⇒ ν-ep (eps1 ... eps2 ...))
|
(⇒ ν #,(make-Branch #'((eff1 ...) (eff2 ...))))]]
|
||||||
(⇒ ν-f #,(make-Branch #'((fs1 ...) (fs2 ...))))
|
|
||||||
(⇒ ν-s (ss1 ... ss2 ...))]]
|
|
||||||
[(_ e_tst e1 e2) ≫
|
[(_ e_tst e1 e2) ≫
|
||||||
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
||||||
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
||||||
[⊢ e1 ≫ e1- (⇒ : τ1)
|
[⊢ e1 ≫ e1- (⇒ : τ1) (⇒ ν (~effs eff1 ...))]
|
||||||
(⇒ ν-ep (~effs eps1 ...)) (⇒ ν-f (~effs fs1 ...)) (⇒ ν-s (~effs ss1 ...))]
|
[⊢ e2 ≫ e2- (⇒ : τ2) (⇒ ν (~effs eff2 ...))]
|
||||||
[⊢ e2 ≫ e2- (⇒ : τ2)
|
|
||||||
(⇒ ν-ep (~effs eps2 ...)) (⇒ ν-f (~effs fs2 ...)) (⇒ ν-s (~effs ss2 ...))]
|
|
||||||
#:with τ (mk-U- #'(τ1 τ2))
|
#:with τ (mk-U- #'(τ1 τ2))
|
||||||
--------
|
--------
|
||||||
[⊢ (if- e_tst- e1- e2-) (⇒ : τ)
|
[⊢ (if- e_tst- e1- e2-) (⇒ : τ)
|
||||||
(⇒ ν-ep (eps1 ... eps2 ...))
|
(⇒ ν #,(make-Branch #'((eff1 ...) (eff2 ...))))]])
|
||||||
(⇒ ν-f #,(make-Branch #'((fs1 ...) (fs2 ...))))
|
|
||||||
(⇒ ν-s (ss1 ... ss2 ...))]])
|
|
||||||
|
|
||||||
(define-typed-syntax (when e s ...+) ≫
|
(define-typed-syntax (when e s ...+) ≫
|
||||||
------------------------------------
|
------------------------------------
|
||||||
|
@ -84,38 +77,31 @@
|
||||||
------------------------------------
|
------------------------------------
|
||||||
[≻ (if e #f (let () s ...))])
|
[≻ (if e #f (let () s ...))])
|
||||||
|
|
||||||
|
|
||||||
;; copied from ext-stlc
|
;; copied from ext-stlc
|
||||||
(define-typed-syntax let
|
(define-typed-syntax let
|
||||||
[(_ ([x e] ...) e_body ...) ⇐ τ_expected ≫
|
[(_ ([x e] ...) e_body ...) ⇐ τ_expected ≫
|
||||||
[⊢ e ≫ e- ⇒ : τ_x] ...
|
[⊢ e ≫ e- ⇒ : τ_x] ...
|
||||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
||||||
[[x ≫ x- : τ_x] ... ⊢ (begin e_body ...) ≫ e_body- (⇐ : τ_expected)
|
[[x ≫ x- : τ_x] ... ⊢ (block e_body ...) ≫ e_body- (⇐ : τ_expected)
|
||||||
(⇒ ν-ep (~effs eps ...))
|
(⇒ ν (~effs eff ...))]
|
||||||
(⇒ ν-f (~effs fs ...))
|
|
||||||
(⇒ ν-s (~effs ss ...))]
|
|
||||||
----------------------------------------------------------
|
----------------------------------------------------------
|
||||||
[⊢ (let- ([x- e-] ...) e_body-) (⇒ : τ_expected)
|
[⊢ (let- ([x- e-] ...) e_body-) (⇒ : τ_expected)
|
||||||
(⇒ ν-ep (eps ...))
|
(⇒ ν (eff ...))]]
|
||||||
(⇒ ν-f (fs ...))
|
|
||||||
(⇒ ν-s (ss ...))]]
|
|
||||||
[(_ ([x e] ...) e_body ...) ≫
|
[(_ ([x e] ...) e_body ...) ≫
|
||||||
[⊢ e ≫ e- ⇒ : τ_x] ...
|
[⊢ e ≫ e- ⇒ : τ_x] ...
|
||||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
||||||
[[x ≫ x- : τ_x] ... ⊢ (begin e_body ...) ≫ e_body- (⇒ : τ_body)
|
[[x ≫ x- : τ_x] ... ⊢ (block e_body ...) ≫ e_body- (⇒ : τ_body)
|
||||||
(⇒ ν-ep (~effs eps ...))
|
(⇒ ν (~effs eff ...))]
|
||||||
(⇒ ν-f (~effs fs ...))
|
|
||||||
(⇒ ν-s (~effs ss ...))]
|
|
||||||
----------------------------------------------------------
|
----------------------------------------------------------
|
||||||
[⊢ (let- ([x- e-] ...) e_body-) (⇒ : τ_body)
|
[⊢ (let- ([x- e-] ...) e_body-) (⇒ : τ_body)
|
||||||
(⇒ ν-ep (eps ...))
|
(⇒ ν (eff ...))]])
|
||||||
(⇒ ν-f (fs ...))
|
|
||||||
(⇒ ν-s (ss ...))]])
|
|
||||||
|
|
||||||
;; copied from ext-stlc
|
;; copied from ext-stlc
|
||||||
(define-typed-syntax let*
|
(define-typed-syntax let*
|
||||||
[(_ () e_body ...) ≫
|
[(_ () e_body ...) ≫
|
||||||
--------
|
--------
|
||||||
[≻ (begin e_body ...)]]
|
[≻ (block e_body ...)]]
|
||||||
[(_ ([x e] [x_rst e_rst] ...) e_body ...) ≫
|
[(_ ([x e] [x_rst e_rst] ...) e_body ...) ≫
|
||||||
--------
|
--------
|
||||||
[≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body ...))]])
|
[≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body ...))]])
|
||||||
|
@ -123,15 +109,11 @@
|
||||||
(define-typed-syntax (cond [pred:expr s ...+] ...+) ≫
|
(define-typed-syntax (cond [pred:expr s ...+] ...+) ≫
|
||||||
[⊢ pred ≫ pred- (⇐ : Bool)] ...
|
[⊢ pred ≫ pred- (⇐ : Bool)] ...
|
||||||
#:fail-unless (stx-andmap pure? #'(pred- ...)) "predicates must be pure"
|
#:fail-unless (stx-andmap pure? #'(pred- ...)) "predicates must be pure"
|
||||||
[⊢ (begin s ...) ≫ s- (⇒ : τ-s)
|
[⊢ (block s ...) ≫ s- (⇒ : τ-s)
|
||||||
(⇒ ν-ep (~effs eps ...))
|
(⇒ ν (~effs eff ...))] ...
|
||||||
(⇒ ν-f (~effs fs ...))
|
|
||||||
(⇒ ν-s (~effs ss ...))] ...
|
|
||||||
------------------------------------------------
|
------------------------------------------------
|
||||||
[⊢ (cond- [pred- s-] ...) (⇒ : (U τ-s ...))
|
[⊢ (cond- [pred- s-] ...) (⇒ : (U τ-s ...))
|
||||||
(⇒ ν-ep (eps ... ...))
|
(⇒ ν #,(make-Branch #'((eff ...) ...)))])
|
||||||
(⇒ ν-f #,(make-Branch #'((fs ...) ...)))
|
|
||||||
(⇒ ν-s (ss ... ...))])
|
|
||||||
|
|
||||||
(define else #t)
|
(define else #t)
|
||||||
|
|
||||||
|
@ -141,10 +123,8 @@
|
||||||
#:with (p/e ...) (for/list ([pat (in-syntax #'(p ...))])
|
#:with (p/e ...) (for/list ([pat (in-syntax #'(p ...))])
|
||||||
(elaborate-pattern/with-type pat #'τ-e))
|
(elaborate-pattern/with-type pat #'τ-e))
|
||||||
#:with (([x τ:type] ...) ...) (stx-map pat-bindings #'(p/e ...))
|
#:with (([x τ:type] ...) ...) (stx-map pat-bindings #'(p/e ...))
|
||||||
[[x ≫ x- : τ.norm] ... ⊢ (begin s ...) ≫ s- (⇒ : τ-s)
|
[[x ≫ x- : τ.norm] ... ⊢ (block s ...) ≫ s- (⇒ : τ-s)
|
||||||
(⇒ ν-ep (~effs eps ...))
|
(⇒ ν (~effs eff ...))] ...
|
||||||
(⇒ ν-f (~effs fs ...))
|
|
||||||
(⇒ ν-s (~effs ss ...))] ...
|
|
||||||
;; REALLY not sure how to handle p/p-/p.match-pattern,
|
;; REALLY not sure how to handle p/p-/p.match-pattern,
|
||||||
;; particularly w.r.t. typed terms that appear in p.match-pattern
|
;; particularly w.r.t. typed terms that appear in p.match-pattern
|
||||||
[⊢ p/e ≫ p-- ⇒ τ-p] ...
|
[⊢ p/e ≫ p-- ⇒ τ-p] ...
|
||||||
|
@ -158,26 +138,29 @@
|
||||||
[⊢ (match- e- [p- s-] ...
|
[⊢ (match- e- [p- s-] ...
|
||||||
[_ (#%app- error- "incomplete pattern match")])
|
[_ (#%app- error- "incomplete pattern match")])
|
||||||
(⇒ : (U τ-s ...))
|
(⇒ : (U τ-s ...))
|
||||||
(⇒ ν-ep (eps ... ...))
|
(⇒ ν #,(make-Branch #'((eff ...) ...)))])
|
||||||
(⇒ ν-f #,(make-Branch #'((fs ...) ...)))
|
|
||||||
(⇒ ν-s (ss ... ...))])
|
|
||||||
|
;; (Listof Value) -> Value
|
||||||
|
(define- (mk-tuple es)
|
||||||
|
(#%app- cons- 'tuple es))
|
||||||
|
|
||||||
(define-typed-syntax (tuple e:expr ...) ≫
|
(define-typed-syntax (tuple e:expr ...) ≫
|
||||||
[⊢ e ≫ e- (⇒ : τ)] ...
|
[⊢ e ≫ e- (⇒ : τ) (⇒ ν (~effs F ...))] ...
|
||||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
|
|
||||||
-----------------------
|
-----------------------
|
||||||
[⊢ (#%app- list- 'tuple e- ...) (⇒ : (Tuple τ ...))])
|
[⊢ (#%app- mk-tuple (#%app- list- e- ...))
|
||||||
|
(⇒ : (Tuple τ ...))
|
||||||
|
(⇒ ν (F ... ...))])
|
||||||
|
|
||||||
(define unit : Unit (tuple))
|
(define unit : Unit (tuple))
|
||||||
|
|
||||||
(define-typed-syntax (select n:nat e:expr) ≫
|
(define-typed-syntax (select n:nat e:expr) ≫
|
||||||
[⊢ e ≫ e- (⇒ : (~Tuple τ ...))]
|
[⊢ e ≫ e- (⇒ : (~Tuple τ ...)) (⇒ ν (~effs F ...))]
|
||||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
|
||||||
#:do [(define i (syntax->datum #'n))]
|
#:do [(define i (syntax->datum #'n))]
|
||||||
#:fail-unless (< i (stx-length #'(τ ...))) "index out of range"
|
#:fail-unless (< i (stx-length #'(τ ...))) "index out of range"
|
||||||
#:with τr (list-ref (stx->list #'(τ ...)) i)
|
#:with τr (list-ref (stx->list #'(τ ...)) i)
|
||||||
--------------------------------------------------------------
|
--------------------------------------------------------------
|
||||||
[⊢ (#%app- tuple-select n e-) (⇒ : τr)])
|
[⊢ (#%app- tuple-select n e-) (⇒ : τr) (⇒ ν (F ...))])
|
||||||
|
|
||||||
(define- (tuple-select n t)
|
(define- (tuple-select n t)
|
||||||
(#%app- list-ref- t (#%app- add1- n)))
|
(#%app- list-ref- t (#%app- add1- n)))
|
||||||
|
@ -202,8 +185,6 @@
|
||||||
[(tuple p ...)
|
[(tuple p ...)
|
||||||
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||||
#'([x τ] ... ...)]
|
#'([x τ] ... ...)]
|
||||||
#;[(k:kons1 p)
|
|
||||||
(pat-bindings #'p)]
|
|
||||||
[(~constructor-exp cons p ...)
|
[(~constructor-exp cons p ...)
|
||||||
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||||
#'([x τ] ... ...)]
|
#'([x τ] ... ...)]
|
||||||
|
@ -257,12 +238,16 @@
|
||||||
[(tuple p ...)
|
[(tuple p ...)
|
||||||
(quasisyntax/loc pat
|
(quasisyntax/loc pat
|
||||||
(tuple #,@(stx-map elaborate-pattern #'(p ...))))]
|
(tuple #,@(stx-map elaborate-pattern #'(p ...))))]
|
||||||
[(k:kons1 p)
|
|
||||||
(quasisyntax/loc pat
|
|
||||||
(k #,(elaborate-pattern #'p)))]
|
|
||||||
[(~constructor-exp ctor p ...)
|
[(~constructor-exp ctor p ...)
|
||||||
|
(define field-tys (ctor-field-tys #'ctor))
|
||||||
|
(define sub-pats
|
||||||
|
(for/list ([field-pat (in-syntax #'(p ...))]
|
||||||
|
[field-ty? (in-list field-tys)])
|
||||||
|
(if field-ty?
|
||||||
|
(elaborate-pattern/with-type field-pat field-ty?)
|
||||||
|
(elaborate-pattern field-pat))))
|
||||||
(quasisyntax/loc pat
|
(quasisyntax/loc pat
|
||||||
(ctor #,@(stx-map elaborate-pattern #'(p ...))))]
|
(ctor #,@sub-pats))]
|
||||||
[e:expr
|
[e:expr
|
||||||
#'e]))
|
#'e]))
|
||||||
|
|
||||||
|
@ -274,10 +259,14 @@
|
||||||
[x:dollar-ann-id
|
[x:dollar-ann-id
|
||||||
(syntax/loc pat (bind x.id x.ty))]
|
(syntax/loc pat (bind x.id x.ty))]
|
||||||
[x:dollar-id
|
[x:dollar-id
|
||||||
|
(when (bot? ty)
|
||||||
|
(raise-syntax-error #f "unable to instantiate pattern with matching part of type" pat))
|
||||||
(quasisyntax/loc pat (bind x.id #,ty))]
|
(quasisyntax/loc pat (bind x.id #,ty))]
|
||||||
[($ x:id ty)
|
[($ x:id ty)
|
||||||
(syntax/loc pat (bind x ty))]
|
(syntax/loc pat (bind x ty))]
|
||||||
[($ x:id)
|
[($ x:id)
|
||||||
|
(when (bot? ty)
|
||||||
|
(raise-syntax-error #f "unable to instantiate pattern with matching part of type" pat))
|
||||||
(quasisyntax/loc pat (bind x #,ty))]
|
(quasisyntax/loc pat (bind x #,ty))]
|
||||||
[(tuple p ...)
|
[(tuple p ...)
|
||||||
(define (matching? t)
|
(define (matching? t)
|
||||||
|
@ -316,6 +305,7 @@
|
||||||
(define (proj t i)
|
(define (proj t i)
|
||||||
(syntax-parse t
|
(syntax-parse t
|
||||||
[(~constructor-type _ tt ...)
|
[(~constructor-type _ tt ...)
|
||||||
|
#:when (matching? t)
|
||||||
(if (= i -1)
|
(if (= i -1)
|
||||||
t
|
t
|
||||||
(stx-list-ref #'(tt ...) i))]
|
(stx-list-ref #'(tt ...) i))]
|
||||||
|
@ -342,8 +332,6 @@
|
||||||
#:datum-literals (tuple discard bind)
|
#:datum-literals (tuple discard bind)
|
||||||
[(tuple p ...)
|
[(tuple p ...)
|
||||||
#`(#,list-binding 'tuple #,@(stx-map loop #'(p ...)))]
|
#`(#,list-binding 'tuple #,@(stx-map loop #'(p ...)))]
|
||||||
#;[(k:kons1 p)
|
|
||||||
#`(#,(kons1->constructor #'k) #,(loop #'p))]
|
|
||||||
[(bind x:id τ:type)
|
[(bind x:id τ:type)
|
||||||
(bind-id-transformer #'x)]
|
(bind-id-transformer #'x)]
|
||||||
[discard
|
[discard
|
||||||
|
@ -370,7 +358,6 @@
|
||||||
[⊢ e ≫ e- (⇒ (~Tuple τ ...))]
|
[⊢ e ≫ e- (⇒ (~Tuple τ ...))]
|
||||||
#:fail-unless (stx-length=? #'(x ...) #'(τ ...))
|
#:fail-unless (stx-length=? #'(x ...) #'(τ ...))
|
||||||
"mismatched size"
|
"mismatched size"
|
||||||
#:fail-unless (pure? #'e-) "expr must be pure"
|
|
||||||
#:with (sel ...) (for/list ([y (in-syntax #'(x ...))]
|
#:with (sel ...) (for/list ([y (in-syntax #'(x ...))]
|
||||||
[t (in-syntax #'(τ ...))]
|
[t (in-syntax #'(τ ...))]
|
||||||
[i (in-naturals)])
|
[i (in-naturals)])
|
File diff suppressed because it is too large
Load Diff
|
@ -62,7 +62,7 @@
|
||||||
(U (Observe (Observe (TcpConnection ★/t (TcpListener ★/t))))
|
(U (Observe (Observe (TcpConnection ★/t (TcpListener ★/t))))
|
||||||
(Observe (TcpConnection ★/t (TcpListener Int)))
|
(Observe (TcpConnection ★/t (TcpListener Int)))
|
||||||
(Observe (TcpConnection ★/t (TcpListener Int)))
|
(Observe (TcpConnection ★/t (TcpListener Int)))
|
||||||
(Advertise (Observe (TcpChannel ★/t (TcpListener (TcpHandle (Seal ★/t)) ★/t))))
|
(Advertise (Observe (TcpChannel ★/t (TcpListener (TcpHandle (Seal ★/t))) ★/t)))
|
||||||
(Observe (Advertise (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ★/t)))
|
(Observe (Advertise (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ★/t)))
|
||||||
(TcpAccepted ★/t)
|
(TcpAccepted ★/t)
|
||||||
(Advertise (TcpChannel (TcpHandle (Seal ★/t)) (TcpAddress String Int) ★/t))
|
(Advertise (TcpChannel (TcpHandle (Seal ★/t)) (TcpAddress String Int) ★/t))
|
||||||
|
@ -102,7 +102,7 @@
|
||||||
|
|
||||||
(require/typed syndicate/drivers/tcp2)
|
(require/typed syndicate/drivers/tcp2)
|
||||||
(require/typed (submod syndicate/drivers/tcp2 syndicate-main)
|
(require/typed (submod syndicate/drivers/tcp2 syndicate-main)
|
||||||
[activate! : (→ (Computation (Value (U))
|
[activate! : (proc → (U) #:effects ((Actor Tcp2Driver))) #;(→ (Computation (Value (U))
|
||||||
(Endpoints)
|
(Endpoints)
|
||||||
(Roles)
|
(Roles)
|
||||||
(Spawns (Actor Tcp2Driver))))])
|
(Spawns (Actor Tcp2Driver))))])
|
|
@ -0,0 +1,22 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(provide activate!
|
||||||
|
later-than
|
||||||
|
LaterThanT
|
||||||
|
LaterThan
|
||||||
|
TimeStateDriver)
|
||||||
|
|
||||||
|
(require-struct later-than
|
||||||
|
#:as LaterThanT
|
||||||
|
#:from syndicate/drivers/timestate)
|
||||||
|
|
||||||
|
(define-type-alias LaterThan (LaterThanT Int))
|
||||||
|
|
||||||
|
(define-type-alias TimeStateDriver
|
||||||
|
(U LaterThan
|
||||||
|
(Observe (LaterThanT ★/t))))
|
||||||
|
|
||||||
|
;; TODO ignoring other driver underneath it
|
||||||
|
|
||||||
|
(require/typed (submod syndicate/drivers/timestate syndicate-main)
|
||||||
|
[activate! : (proc → ⊥ #:spawns ((Actor TimeStateDriver)))])
|
|
@ -22,13 +22,14 @@
|
||||||
(define (∀ (X Y Z) (partition/either [xs : (List X)]
|
(define (∀ (X Y Z) (partition/either [xs : (List X)]
|
||||||
[pred : (→fn X (Either Y Z))]
|
[pred : (→fn X (Either Y Z))]
|
||||||
-> (Tuple (List Y) (List Z))))
|
-> (Tuple (List Y) (List Z))))
|
||||||
(for/fold ([acc (Tuple (List Y) (List Z)) (tuple (list) (list))])
|
(for/fold ([lefts (List Y) (list)]
|
||||||
|
[rights (List Z) (list)])
|
||||||
([x xs])
|
([x xs])
|
||||||
(define y-or-z (pred x))
|
(define y-or-z (pred x))
|
||||||
(match y-or-z
|
(match y-or-z
|
||||||
[(left (bind y Y))
|
[(left (bind y Y))
|
||||||
(tuple (cons y (select 0 acc))
|
(tuple (cons y lefts)
|
||||||
(select 1 acc))]
|
rights)]
|
||||||
[(right (bind z Z))
|
[(right (bind z Z))
|
||||||
(tuple (select 0 acc)
|
(tuple lefts
|
||||||
(cons z (select 1 acc)))])))
|
(cons z rights))])))
|
|
@ -12,8 +12,8 @@
|
||||||
(require (only-in "list.rkt" List ~List))
|
(require (only-in "list.rkt" List ~List))
|
||||||
(require (only-in "set.rkt" Set ~Set))
|
(require (only-in "set.rkt" Set ~Set))
|
||||||
(require (only-in "hash.rkt" Hash ~Hash))
|
(require (only-in "hash.rkt" Hash ~Hash))
|
||||||
(require (only-in "prim.rkt" Bool + #%datum))
|
(require (only-in "prim.rkt" Int Bool + #%datum))
|
||||||
(require (only-in "core-expressions.rkt" let unit))
|
(require (only-in "core-expressions.rkt" let unit tuple-select mk-tuple))
|
||||||
(require "maybe.rkt")
|
(require "maybe.rkt")
|
||||||
|
|
||||||
(require (postfix-in - (only-in racket/set
|
(require (postfix-in - (only-in racket/set
|
||||||
|
@ -115,75 +115,106 @@
|
||||||
(type-error #:src e
|
(type-error #:src e
|
||||||
#:msg "not an iterable type: ~a" τ)]))
|
#:msg "not an iterable type: ~a" τ)]))
|
||||||
|
|
||||||
|
(define-for-syntax (bind-renames renames body)
|
||||||
|
(syntax-parse renames
|
||||||
|
[([x:id x-:id] ...)
|
||||||
|
#:with (x-- ...) (map syntax-local-identifier-as-binding (syntax->list #'(x- ...)))
|
||||||
|
(quasisyntax/loc body
|
||||||
|
(let- ()
|
||||||
|
(define-syntax x (make-variable-like-transformer #'x--)) ...
|
||||||
|
#,body))]))
|
||||||
|
|
||||||
(define-typed-syntax for/fold
|
(define-typed-syntax for/fold
|
||||||
[(for/fold ([acc:id (~optional (~datum :)) τ-acc init])
|
[(for/fold ([acc:id (~optional (~datum :)) τ-acc init] ...+)
|
||||||
(clause:iter-clause
|
(clause:iter-clause
|
||||||
...)
|
...)
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
[⊢ init ≫ init- (⇐ : τ-acc)]
|
[⊢ init ≫ init- (⇐ : τ-acc)] ...
|
||||||
#:fail-unless (pure? #'init-) "expression must be pure"
|
#:fail-unless (all-pure? #'(init- ...)) "expression must be pure"
|
||||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||||
[[x ≫ x-- : τ] ...
|
#:do [(define num-accs (length (syntax->list #'(τ-acc ...))))]
|
||||||
[acc ≫ acc- : τ-acc] ⊢ (begin e-body ...) ≫ e-body-
|
#:with body-ty (if (= 1 num-accs)
|
||||||
(⇐ : τ-acc)
|
(first (syntax->list #'(τ-acc ...)))
|
||||||
(⇒ ν-ep (~effs τ-ep ...))
|
(type-eval #'(Tuple (~@ τ-acc ...))))
|
||||||
(⇒ ν-s (~effs τ-s ...))
|
[[[x ≫ x-- : τ] ...]
|
||||||
(⇒ ν-f (~effs τ-f ...))]
|
[[acc ≫ acc- : τ-acc] ...] ⊢ (block e-body ...) ≫ e-body-
|
||||||
#:with e-body-- (substs #'(x- ...) #'(x-- ...) #'e-body- free-identifier=?)
|
(⇐ : body-ty)
|
||||||
|
(⇒ ν (~effs F ...))]
|
||||||
-------------------------------------------------------
|
-------------------------------------------------------
|
||||||
[⊢ (for/fold- ([acc- init-])
|
[⊢ (values->tuple #,num-accs
|
||||||
clauses-
|
(for/fold- ([acc- init-] ...)
|
||||||
e-body--)
|
clauses-
|
||||||
(⇒ : τ-acc)
|
#,(bind-renames #'([x-- x-] ...) #`(tuple->values #,num-accs e-body-))))
|
||||||
(⇒ ν-ep (τ-ep ...))
|
(⇒ : body-ty)
|
||||||
(⇒ ν-s (τ-s ...))
|
(⇒ ν (F ...))]]
|
||||||
(⇒ ν-f (τ-f ...))]]
|
[(for/fold (accs ... [acc:id init] more-accs ...)
|
||||||
[(for/fold ([acc:id init])
|
|
||||||
clauses
|
clauses
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
[⊢ init ≫ _ (⇒ : τ-acc)]
|
[⊢ init ≫ _ (⇒ : τ-acc)]
|
||||||
---------------------------------------------------
|
---------------------------------------------------
|
||||||
[≻ (for/fold ([acc τ-acc init])
|
[≻ (for/fold (accs ... [acc τ-acc init] more-accs ...)
|
||||||
clauses
|
clauses
|
||||||
e-body ...)]])
|
e-body ...)]])
|
||||||
|
|
||||||
|
(define-syntax-parser tuple->values
|
||||||
|
[(_ n:nat e:expr)
|
||||||
|
(define arity (syntax-e #'n))
|
||||||
|
(cond
|
||||||
|
[(= 1 arity)
|
||||||
|
#'e]
|
||||||
|
[else
|
||||||
|
(define/with-syntax tmp (generate-temporary 'tup))
|
||||||
|
(define projections
|
||||||
|
(for/list ([i (in-range arity)])
|
||||||
|
#`(#%app- tuple-select #,i tmp)))
|
||||||
|
#`(let- ([tmp e])
|
||||||
|
(#%app- values- #,@projections))])])
|
||||||
|
|
||||||
|
#;(tuple->values 1 (tuple 0))
|
||||||
|
|
||||||
|
(define-syntax-parser values->tuple
|
||||||
|
[(_ n:nat e:expr)
|
||||||
|
(define arity (syntax-e #'n))
|
||||||
|
(cond
|
||||||
|
[(= 1 arity)
|
||||||
|
#'e]
|
||||||
|
[else
|
||||||
|
(define/with-syntax (tmp ...) (generate-temporaries (make-list arity 'values->tuple)))
|
||||||
|
#`(let-values- ([(tmp ...) e])
|
||||||
|
(#%app- mk-tuple (#%app- list- tmp ...)))])])
|
||||||
|
|
||||||
(define-typed-syntax (for/list (clause:iter-clause ...)
|
(define-typed-syntax (for/list (clause:iter-clause ...)
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||||
[[x ≫ x-- : τ] ... ⊢ (begin e-body ...) ≫ e-body-
|
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
||||||
(⇒ : τ-body)
|
(⇒ : τ-body)
|
||||||
(⇒ ν-ep (~effs τ-ep ...))
|
(⇒ ν-ep (~effs τ-ep ...))
|
||||||
(⇒ ν-s (~effs τ-s ...))
|
(⇒ ν-s (~effs τ-s ...))
|
||||||
(⇒ ν-f (~effs τ-f ...))]
|
(⇒ ν-f (~effs τ-f ...))]
|
||||||
#:with e-body-- (substs #'(x- ...) #'(x-- ...) #'e-body- free-identifier=?)
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
[⊢ (for/list- clauses-
|
[⊢ (for/list- clauses-
|
||||||
e-body--) (⇒ : (List τ-body))
|
#,(bind-renames #'([x-- x-] ...) #'e-body-))
|
||||||
(⇒ ν-ep (τ-ep ...))
|
(⇒ : (List τ-body))
|
||||||
(⇒ ν-s (τ-s ...))
|
(⇒ ν-ep (τ-ep ...))
|
||||||
(⇒ ν-f (τ-f ...))])
|
(⇒ ν-s (τ-s ...))
|
||||||
|
(⇒ ν-f (τ-f ...))])
|
||||||
|
|
||||||
(define-typed-syntax (for/set (clause:iter-clause ...)
|
(define-typed-syntax (for/set (clause:iter-clause ...)
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||||
[[x ≫ x-- : τ] ... ⊢ (begin e-body ...) ≫ e-body-
|
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
||||||
(⇒ : τ-body)
|
(⇒ : τ-body)
|
||||||
(⇒ ν-ep (~effs τ-ep ...))
|
(⇒ ν (~effs F ...))]
|
||||||
(⇒ ν-s (~effs τ-s ...))
|
|
||||||
(⇒ ν-f (~effs τ-f ...))]
|
|
||||||
#:with e-body-- (substs #'(x- ...) #'(x-- ...) #'e-body- free-identifier=?)
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
[⊢ (for/set- clauses-
|
[⊢ (for/set- clauses-
|
||||||
e-body--) (⇒ : (Set τ-body))
|
#,(bind-renames #'([x-- x-] ...) #'e-body-))
|
||||||
(⇒ ν-ep (τ-ep ...))
|
(⇒ : (Set τ-body))
|
||||||
(⇒ ν-s (τ-s ...))
|
(⇒ ν (F ...))])
|
||||||
(⇒ ν-f (τ-f ...))])
|
|
||||||
|
|
||||||
(define-typed-syntax (for/sum (clause ...)
|
(define-typed-syntax (for/sum (clause ...)
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
[≻ (for/fold ([acc 0])
|
[≻ (for/fold ([acc Int 0])
|
||||||
(clause ...)
|
(clause ...)
|
||||||
(+ acc (let () e-body ...)))])
|
(+ acc (let () e-body ...)))])
|
||||||
|
|
||||||
|
@ -198,22 +229,17 @@
|
||||||
(define-typed-syntax (for/first (clause:iter-clause ...)
|
(define-typed-syntax (for/first (clause:iter-clause ...)
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||||
[[x ≫ x-- : τ] ... ⊢ (begin e-body ...) ≫ e-body-
|
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
||||||
(⇒ : τ-body)
|
(⇒ : τ-body)
|
||||||
(⇒ ν-ep (~effs τ-ep ...))
|
(⇒ ν (~effs F ...))]
|
||||||
(⇒ ν-s (~effs τ-s ...))
|
|
||||||
(⇒ ν-f (~effs τ-f ...))]
|
|
||||||
#:with e-body-- (substs #'(x- ...) #'(x-- ...) #'e-body- free-identifier=?)
|
|
||||||
[[res ≫ _ : τ-body] ⊢ res ≫ res- (⇒ : _)]
|
[[res ≫ _ : τ-body] ⊢ res ≫ res- (⇒ : _)]
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
[⊢ (let- ()
|
[⊢ (let- ()
|
||||||
(define- res-
|
(define- res-
|
||||||
(for/first- clauses-
|
(for/first- clauses-
|
||||||
e-body--))
|
#,(bind-renames #'([x-- x-] ...) #'e-body-)))
|
||||||
(if- res-
|
(if- res-
|
||||||
(some res-)
|
(some res-)
|
||||||
none))
|
none))
|
||||||
(⇒ : (Maybe τ-body))
|
(⇒ : (Maybe τ-body))
|
||||||
(⇒ ν-ep (τ-ep ...))
|
(⇒ ν (F ...))])
|
||||||
(⇒ ν-s (τ-s ...))
|
|
||||||
(⇒ ν-f (τ-f ...))])
|
|
|
@ -33,32 +33,20 @@
|
||||||
|
|
||||||
(define-container-type Hash #:arity = 2)
|
(define-container-type Hash #:arity = 2)
|
||||||
|
|
||||||
(begin-for-syntax
|
(define-typed-syntax (hash (~seq key:expr val:expr) ...) ≫
|
||||||
(define-splicing-syntax-class key-val-list
|
|
||||||
#:attributes (items)
|
|
||||||
(pattern (~seq k1 v1 rest:key-val-list)
|
|
||||||
#:attr items #`((k1 v1) #,@#'rest.items))
|
|
||||||
(pattern (~seq)
|
|
||||||
#:attr items #'())))
|
|
||||||
|
|
||||||
(define-typed-syntax (hash keys&vals:key-val-list) ≫
|
|
||||||
#:with ((key val) ...) #'keys&vals.items
|
|
||||||
[⊢ key ≫ key- (⇒ : τ-k)] ...
|
[⊢ key ≫ key- (⇒ : τ-k)] ...
|
||||||
[⊢ val ≫ val- (⇒ : τ-val)] ...
|
[⊢ val ≫ val- (⇒ : τ-val)] ...
|
||||||
#:fail-unless (all-pure? #'(key- ... val- ...)) "gotta be pure"
|
#:fail-unless (all-pure? #'(key- ... val- ...)) "gotta be pure"
|
||||||
#:with together-again (stx-flatten #'((key- val-) ...))
|
|
||||||
--------------------------------------------------
|
--------------------------------------------------
|
||||||
[⊢ (#%app- hash- #,@#'together-again) (⇒ : (Hash (U τ-k ...) (U τ-val ...)))])
|
[⊢ (#%app- hash- (~@ key val) ...) (⇒ : (Hash (U τ-k ...) (U τ-val ...)))])
|
||||||
|
|
||||||
(require/typed racket/base
|
(require/typed racket/base
|
||||||
;; don't have a type for ConsPair
|
;; don't have a type for ConsPair
|
||||||
#;[make-hash : (∀ (K V) (→fn (List (ConsPair K V)) (Hash K V)))]
|
#;[make-hash : (∀ (K V) (→fn (List (ConsPair K V)) (Hash K V)))]
|
||||||
[hash-set : (∀ (K V) (→fn (Hash K V) K V (Hash K V)))]
|
[hash-set : (∀ (K V) (→fn (Hash K V) K V (Hash K V)))]
|
||||||
[hash-ref : (∀ (K V) (→fn (Hash K V) K V))]
|
[hash-ref : (∀ (K V) (→fn (Hash K V) K V))]
|
||||||
;; TODO hash-ref/failure
|
|
||||||
[hash-has-key? : (∀ (K V) (→fn (Hash K V) K Bool))]
|
[hash-has-key? : (∀ (K V) (→fn (Hash K V) K Bool))]
|
||||||
[hash-update : (∀ (K V) (→fn (Hash K V) K (→fn V V) (Hash K V)))]
|
[hash-update : (∀ (K V) (→fn (Hash K V) K (→fn V V) (Hash K V)))]
|
||||||
;; TODO hash-update/failure
|
|
||||||
[hash-remove : (∀ (K V) (→fn (Hash K V) K (Hash K V)))]
|
[hash-remove : (∀ (K V) (→fn (Hash K V) K (Hash K V)))]
|
||||||
[hash-map : (∀ (K V R) (→fn (Hash K V) (→fn K V R) (List R)))]
|
[hash-map : (∀ (K V R) (→fn (Hash K V) (→fn K V R) (List R)))]
|
||||||
[hash-keys : (∀ (K V) (→fn (Hash K V) (List K)))]
|
[hash-keys : (∀ (K V) (→fn (Hash K V) (List K)))]
|
||||||
|
@ -71,7 +59,6 @@
|
||||||
|
|
||||||
(require/typed racket/hash
|
(require/typed racket/hash
|
||||||
[hash-union : (∀ (K1 V1 K2 V2) (→fn (Hash K1 V1) (Hash K2 V2) (Hash (U K1 K2) (U V1 V2))))]
|
[hash-union : (∀ (K1 V1 K2 V2) (→fn (Hash K1 V1) (Hash K2 V2) (Hash (U K1 K2) (U V1 V2))))]
|
||||||
;; TODO - hash-union with #:combine
|
|
||||||
)
|
)
|
||||||
|
|
||||||
(define- (hash-ref/failure- h k err)
|
(define- (hash-ref/failure- h k err)
|
|
@ -1,2 +1,2 @@
|
||||||
#lang s-exp syntax/module-reader
|
#lang s-exp syntax/module-reader
|
||||||
typed/main
|
typed/syndicate/roles
|
||||||
|
|
|
@ -3,18 +3,24 @@
|
||||||
(provide List
|
(provide List
|
||||||
(for-syntax ~List)
|
(for-syntax ~List)
|
||||||
list
|
list
|
||||||
(typed-out [[cons- : (∀ (X) (→fn X (List X) (List X)))] cons]
|
(typed-out [[empty- : (List ⊥)] empty]
|
||||||
|
[[empty?- : (∀ (X) (→fn (List X) Bool))] empty?]
|
||||||
|
[[cons- : (∀ (X) (→fn X (List X) (List X)))] cons]
|
||||||
|
[[cons?- : (∀ (X) (→fn X (List X) Bool))] cons?]
|
||||||
[[first- : (∀ (X) (→fn (List X) X))] first]
|
[[first- : (∀ (X) (→fn (List X) X))] first]
|
||||||
[[second- : (∀ (X) (→fn (List X) X))] second]
|
[[second- : (∀ (X) (→fn (List X) X))] second]
|
||||||
[[rest- : (∀ (X) (→fn (List X) (List X)))] rest]
|
[[rest- : (∀ (X) (→fn (List X) (List X)))] rest]
|
||||||
[[member?- (∀ (X) (→fn X (List X) Bool))] member?]
|
[[member?- (∀ (X) (→fn X (List X) Bool))] member?]
|
||||||
[[empty?- (∀ (X) (→fn (List X) Bool))] empty?]
|
|
||||||
[[reverse- (∀ (X) (→fn (List X) (List X)))] reverse]
|
[[reverse- (∀ (X) (→fn (List X) (List X)))] reverse]
|
||||||
[[partition- (∀ (X) (→fn (List X) (→fn X Bool) (List X)))] partition]
|
[[partition- (∀ (X) (→fn (List X) (→fn X Bool) (List X)))] partition]
|
||||||
[[map- (∀ (X Y) (→fn (→fn X Y) (List X) (List Y)))] map]))
|
[[map- (∀ (X Y) (→fn (→fn X Y) (List X) (List Y)))] map]
|
||||||
|
[[argmax- : (∀ (X) (→fn (→fn X Int) (List X) X))] argmax]
|
||||||
|
[[argmin- : (∀ (X) (→fn (→fn X Int) (List X) X))] argmin]
|
||||||
|
[[remove- : (∀ (X) (→fn X (List X) (List X)))] remove]
|
||||||
|
[[length- : (∀ (X) (→fn (List X) Int))] length]))
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
(require (only-in "prim.rkt" Bool))
|
(require (only-in "prim.rkt" Bool Int))
|
||||||
(require (postfix-in - racket/list))
|
(require (postfix-in - racket/list))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
@ -0,0 +1,73 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(provide (all-defined-out))
|
||||||
|
|
||||||
|
;; an [LTL X] is one of
|
||||||
|
;; - (always [LTL X])
|
||||||
|
;; - (eventually [LTL X])
|
||||||
|
;; - (weak-until [LTL X] [LTL X])
|
||||||
|
;; - (strong-until [LTL X] [LTL X])
|
||||||
|
;; - (release [LTL X] [LTL X])
|
||||||
|
;; - (ltl-implies [LTL X] [LTL X])
|
||||||
|
;; - (ltl-and [LTL X] [LTL X])
|
||||||
|
;; - (ltl-or [LTL X] [LTL X])
|
||||||
|
;; - (ltl-not [LTL X])
|
||||||
|
;; - (atomic X)
|
||||||
|
;; - Bool
|
||||||
|
;; where X represents the type of atomic propositions
|
||||||
|
|
||||||
|
(struct always [p] #:prefab)
|
||||||
|
(struct eventually [p] #:prefab)
|
||||||
|
(struct atomic [p] #:prefab)
|
||||||
|
(struct weak-until [p q] #:prefab)
|
||||||
|
(struct strong-until [p q] #:prefab)
|
||||||
|
(struct release [p q] #:prefab)
|
||||||
|
(struct ltl-implies [p q] #:prefab)
|
||||||
|
(struct ltl-and [p q] #:prefab)
|
||||||
|
(struct ltl-or [p q] #:prefab)
|
||||||
|
(struct ltl-not [p] #:prefab)
|
||||||
|
|
||||||
|
;; [LTL X] {X -> Y} -> [LTL Y]
|
||||||
|
(define (map-atomic ltl op)
|
||||||
|
(let loop ([ltl ltl])
|
||||||
|
(match ltl
|
||||||
|
[(always p)
|
||||||
|
(always (loop p))]
|
||||||
|
[(eventually p)
|
||||||
|
(eventually (loop p))]
|
||||||
|
[(weak-until p q)
|
||||||
|
(weak-until (loop p) (loop q))]
|
||||||
|
[(strong-until p q)
|
||||||
|
(strong-until (loop p) (loop q))]
|
||||||
|
[(release p q)
|
||||||
|
(release (loop p) (loop q))]
|
||||||
|
[(ltl-implies p q)
|
||||||
|
(ltl-implies (loop p) (loop q))]
|
||||||
|
[(ltl-and p q)
|
||||||
|
(ltl-and (loop p) (loop q))]
|
||||||
|
[(ltl-or p q)
|
||||||
|
(ltl-or (loop p) (loop q))]
|
||||||
|
[(ltl-not p)
|
||||||
|
(ltl-not (loop p))]
|
||||||
|
[(atomic x)
|
||||||
|
(atomic (op x))]
|
||||||
|
[#t
|
||||||
|
#t]
|
||||||
|
[#f
|
||||||
|
#f])))
|
||||||
|
|
||||||
|
(define (&& . args)
|
||||||
|
(fold-bin-op ltl-and args #t))
|
||||||
|
|
||||||
|
(define (|| . args)
|
||||||
|
(fold-bin-op ltl-or args #f))
|
||||||
|
|
||||||
|
(define (fold-bin-op op args base)
|
||||||
|
(let loop ([args args])
|
||||||
|
(match args
|
||||||
|
['()
|
||||||
|
base]
|
||||||
|
[(list x y)
|
||||||
|
(op x y)]
|
||||||
|
[(cons fst rst)
|
||||||
|
(op fst (loop rst))])))
|
|
@ -5,9 +5,12 @@
|
||||||
None*
|
None*
|
||||||
Some
|
Some
|
||||||
some
|
some
|
||||||
none)
|
none
|
||||||
|
has?)
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
|
(require "prim.rkt")
|
||||||
|
(require "core-expressions.rkt")
|
||||||
|
|
||||||
|
|
||||||
(define-constructor* (none* : None*))
|
(define-constructor* (none* : None*))
|
||||||
|
@ -35,3 +38,10 @@
|
||||||
(error "some")]
|
(error "some")]
|
||||||
[none
|
[none
|
||||||
(error "none")]))
|
(error "none")]))
|
||||||
|
|
||||||
|
(define (∀ (X) (has? [v : (Maybe X)] [p : (→fn X Bool)] -> Bool))
|
||||||
|
(match v
|
||||||
|
[none
|
||||||
|
#f]
|
||||||
|
[(some $x)
|
||||||
|
(p x)]))
|
|
@ -1,29 +1,31 @@
|
||||||
#lang turnstile
|
#lang turnstile
|
||||||
|
|
||||||
(provide (all-defined-out)
|
(provide (all-defined-out)
|
||||||
|
True False Bool
|
||||||
(for-syntax (all-defined-out)))
|
(for-syntax (all-defined-out)))
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
(require (rename-in racket/math [exact-truncate exact-truncate-]))
|
(require (rename-in racket/math [exact-truncate exact-truncate-]))
|
||||||
(require (postfix-in - (only-in racket/format ~a)))
|
(require (postfix-in - (only-in racket/format ~a ~v)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Primitives
|
;; Primitives
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-base-types Int Bool String ByteString Symbol)
|
(define-base-types Zero NonZero String ByteString Symbol)
|
||||||
|
|
||||||
|
(define-type-alias Int (U Zero NonZero))
|
||||||
|
|
||||||
;; hmmm
|
;; hmmm
|
||||||
(define-primop + (→ Int Int (Computation (Value Int) (Endpoints) (Roles) (Spawns))))
|
(define-primop + (→fn Int Int Int))
|
||||||
(define-primop - (→ Int Int (Computation (Value Int) (Endpoints) (Roles) (Spawns))))
|
(define-primop - (→fn Int Int Int))
|
||||||
(define-primop * (→ Int Int (Computation (Value Int) (Endpoints) (Roles) (Spawns))))
|
(define-primop * (→fn Int Int Int))
|
||||||
(define-primop or (→ Bool Bool (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop not (→fn Bool Bool))
|
||||||
(define-primop not (→ Bool (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop < (→fn Int Int Bool))
|
||||||
(define-primop < (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop > (→fn Int Int Bool))
|
||||||
(define-primop > (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop <= (→fn Int Int Bool))
|
||||||
(define-primop <= (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop >= (→fn Int Int Bool))
|
||||||
(define-primop >= (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop = (→fn Int Int Bool))
|
||||||
(define-primop = (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
|
||||||
(define-primop even? (→fn Int Bool))
|
(define-primop even? (→fn Int Bool))
|
||||||
(define-primop odd? (→fn Int Bool))
|
(define-primop odd? (→fn Int Bool))
|
||||||
(define-primop add1 (→fn Int Int))
|
(define-primop add1 (→fn Int Int))
|
||||||
|
@ -33,12 +35,14 @@
|
||||||
(define-primop zero? (→fn Int Bool))
|
(define-primop zero? (→fn Int Bool))
|
||||||
(define-primop positive? (→fn Int Bool))
|
(define-primop positive? (→fn Int Bool))
|
||||||
(define-primop negative? (→fn Int Bool))
|
(define-primop negative? (→fn Int Bool))
|
||||||
|
(define-primop current-inexact-milliseconds (→fn Int))
|
||||||
|
(define-primop string=? (→fn String String Bool))
|
||||||
|
|
||||||
(define-primop bytes->string/utf-8 (→ ByteString (Computation (Value String) (Endpoints) (Roles) (Spawns))))
|
(define-primop bytes->string/utf-8 (→fn ByteString String))
|
||||||
(define-primop string->bytes/utf-8 (→ String (Computation (Value ByteString) (Endpoints) (Roles) (Spawns))))
|
(define-primop string->bytes/utf-8 (→fn String ByteString))
|
||||||
(define-primop gensym (→ Symbol (Computation (Value Symbol) (Endpoints) (Roles) (Spawns))))
|
(define-primop gensym (→fn Symbol Symbol))
|
||||||
(define-primop symbol->string (→ Symbol (Computation (Value String) (Endpoints) (Roles) (Spawns))))
|
(define-primop symbol->string (→fn Symbol String))
|
||||||
(define-primop string->symbol (→ String (Computation (Value Symbol) (Endpoints) (Roles) (Spawns))))
|
(define-primop string->symbol (→fn String Symbol))
|
||||||
|
|
||||||
(define-typed-syntax (/ e1 e2) ≫
|
(define-typed-syntax (/ e1 e2) ≫
|
||||||
[⊢ e1 ≫ e1- (⇐ : Int)]
|
[⊢ e1 ≫ e1- (⇐ : Int)]
|
||||||
|
@ -48,13 +52,19 @@
|
||||||
------------------------
|
------------------------
|
||||||
[⊢ (#%app- exact-truncate- (#%app- /- e1- e2-)) (⇒ : Int)])
|
[⊢ (#%app- exact-truncate- (#%app- /- e1- e2-)) (⇒ : Int)])
|
||||||
|
|
||||||
;; for some reason defining `and` as a prim op doesn't work
|
;; I think defining `and` and `or` as primops doesn't work because they're syntax
|
||||||
(define-typed-syntax (and e ...) ≫
|
(define-typed-syntax (and e ...) ≫
|
||||||
[⊢ e ≫ e- (⇐ : Bool)] ...
|
[⊢ e ≫ e- (⇐ : Bool)] ...
|
||||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
|
||||||
------------------------
|
------------------------
|
||||||
[⊢ (and- e- ...) (⇒ : Bool)])
|
[⊢ (and- e- ...) (⇒ : Bool)])
|
||||||
|
|
||||||
|
(define-typed-syntax (or e ...) ≫
|
||||||
|
[⊢ e ≫ e- (⇐ : Bool)] ...
|
||||||
|
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
|
||||||
|
------------------------
|
||||||
|
[⊢ (or- e- ...) (⇒ : Bool)])
|
||||||
|
|
||||||
(define-typed-syntax (equal? e1:expr e2:expr) ≫
|
(define-typed-syntax (equal? e1:expr e2:expr) ≫
|
||||||
[⊢ e1 ≫ e1- (⇒ : τ1)]
|
[⊢ e1 ≫ e1- (⇒ : τ1)]
|
||||||
[⊢ e2 ≫ e2- (⇒ : τ2)]
|
[⊢ e2 ≫ e2- (⇒ : τ2)]
|
||||||
|
@ -89,17 +99,35 @@
|
||||||
--------------------------------------------------
|
--------------------------------------------------
|
||||||
[⊢ (#%app- ~a- e- ...) (⇒ : String)])
|
[⊢ (#%app- ~a- e- ...) (⇒ : String)])
|
||||||
|
|
||||||
|
(define-typed-syntax (~v e ...) ≫
|
||||||
|
[⊢ e ≫ e- (⇒ : τ)] ...
|
||||||
|
#:fail-unless (stx-andmap flat-type? #'(τ ...))
|
||||||
|
"expressions must be string-able"
|
||||||
|
--------------------------------------------------
|
||||||
|
[⊢ (#%app- ~v- e- ...) (⇒ : String)])
|
||||||
|
|
||||||
|
(define-typed-syntax (format s e ...) ≫
|
||||||
|
[⊢ s ≫ s- (⇐ : String)]
|
||||||
|
[⊢ e ≫ e- (⇒ : τ)] ...
|
||||||
|
#:fail-unless (stx-andmap flat-type? #'(τ ...))
|
||||||
|
"expressions must be string-able"
|
||||||
|
--------------------------------------------------
|
||||||
|
[⊢ (#%app- format- s- e- ...) (⇒ : String)])
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Basic Values
|
;; Basic Values
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-typed-syntax #%datum
|
(define-typed-syntax #%datum
|
||||||
[(_ . n:integer) ≫
|
[(_ . n:integer) ≫
|
||||||
|
#:with T (if (zero? (syntax-e #'n)) #'Zero #'NonZero)
|
||||||
----------------
|
----------------
|
||||||
[⊢ (#%datum- . n) (⇒ : Int)]]
|
[⊢ (#%datum- . n) (⇒ : T)]]
|
||||||
[(_ . b:boolean) ≫
|
[(_ . b:boolean)
|
||||||
|
≫
|
||||||
|
#:with T (if (syntax-e #'b) #'True #'False)
|
||||||
----------------
|
----------------
|
||||||
[⊢ (#%datum- . b) (⇒ : Bool)]]
|
[⊢ (#%datum- . b) (⇒ : T)]]
|
||||||
[(_ . s:string) ≫
|
[(_ . s:string) ≫
|
||||||
----------------
|
----------------
|
||||||
[⊢ (#%datum- . s) (⇒ : String)]])
|
[⊢ (#%datum- . s) (⇒ : String)]])
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,3 @@
|
||||||
|
#!/bin/sh
|
||||||
|
|
||||||
|
spin -p -t $1
|
File diff suppressed because it is too large
Load Diff
|
@ -1,2 +1,2 @@
|
||||||
#lang s-exp syntax/module-reader
|
#lang s-exp syntax/module-reader
|
||||||
typed/roles
|
typed/syndicate/roles
|
||||||
|
|
|
@ -0,0 +1,21 @@
|
||||||
|
#!/bin/sh
|
||||||
|
|
||||||
|
pushd ${1%/*}/ > /dev/null
|
||||||
|
|
||||||
|
EXE="$1-verifier.o"
|
||||||
|
|
||||||
|
spin -a $1
|
||||||
|
if [[ $? -ne 0 ]]; then
|
||||||
|
popd > /dev/null
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
gcc -o $EXE -D NFAIR=3 pan.c
|
||||||
|
|
||||||
|
# -a to analyze, -f for (weak) fairness
|
||||||
|
# -n to elide report of unreached states
|
||||||
|
# -N spec-name to verify a particular specification
|
||||||
|
$EXE -a -f -n -N $2
|
||||||
|
rm $EXE pan.*
|
||||||
|
|
||||||
|
popd > /dev/null
|
|
@ -17,12 +17,15 @@
|
||||||
sequence-add-between
|
sequence-add-between
|
||||||
in-list
|
in-list
|
||||||
in-set
|
in-set
|
||||||
|
in-hash-keys
|
||||||
|
in-hash-values
|
||||||
in-range
|
in-range
|
||||||
)
|
)
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
(require (only-in "list.rkt" List))
|
(require (only-in "list.rkt" List))
|
||||||
(require (only-in "set.rkt" Set))
|
(require (only-in "set.rkt" Set))
|
||||||
|
(require (only-in "hash.rkt" Hash))
|
||||||
(require (only-in "prim.rkt" Int Bool))
|
(require (only-in "prim.rkt" Int Bool))
|
||||||
#;(require (postfix-in - racket/sequence))
|
#;(require (postfix-in - racket/sequence))
|
||||||
|
|
||||||
|
@ -50,25 +53,8 @@
|
||||||
|
|
||||||
(require/typed racket/base
|
(require/typed racket/base
|
||||||
[in-list : (∀ (X) (→fn (List X) (Sequence X)))]
|
[in-list : (∀ (X) (→fn (List X) (Sequence X)))]
|
||||||
|
[in-hash-keys : (∀ (K V) (→fn (Hash K V) (Sequence K)))]
|
||||||
|
[in-hash-values : (∀ (K V) (→fn (Hash K V) (Sequence V)))]
|
||||||
[in-range : (→fn Int (Sequence Int))])
|
[in-range : (→fn Int (Sequence Int))])
|
||||||
(require/typed racket/set
|
(require/typed racket/set
|
||||||
[in-set : (∀ (X) (→fn (Set X) (Sequence X)))])
|
[in-set : (∀ (X) (→fn (Set X) (Sequence X)))])
|
||||||
|
|
||||||
#;(define-typed-syntax empty-sequence
|
|
||||||
[_ ≫
|
|
||||||
--------------------
|
|
||||||
[⊢ empty-sequence- (⇒ : (Sequence (U)))]])
|
|
||||||
|
|
||||||
;; er, this is making everything a macro, as opposed to a procedure...
|
|
||||||
;; think I ought to add polymorphous first :\
|
|
||||||
#;(define-typed-syntax (sequence->list s) ≫
|
|
||||||
[⊢ s ≫ s- (⇒ : (~Sequence τ))]
|
|
||||||
#:fail-unless (pure? #'s-)
|
|
||||||
------------------------------
|
|
||||||
[⊢ (sequence->list- s-) (⇒ : (List τ))])
|
|
||||||
|
|
||||||
#;(define-typed-syntax (sequence-length s) ≫
|
|
||||||
[⊢ s ≫ s- (⇒ : (~Sequence τ))]
|
|
||||||
#:fail-unless (pure? #'s-)
|
|
||||||
------------------------------
|
|
||||||
[⊢ (sequence-length- s-) (⇒ : Int)])
|
|
|
@ -3,23 +3,28 @@
|
||||||
(provide Set
|
(provide Set
|
||||||
(for-syntax ~Set)
|
(for-syntax ~Set)
|
||||||
set
|
set
|
||||||
set-member?
|
;; set-member?
|
||||||
set-add
|
;; set-add
|
||||||
set-remove
|
;; set-remove
|
||||||
set-count
|
;; set-count
|
||||||
set-union
|
set-union
|
||||||
set-subtract
|
set-subtract
|
||||||
set-intersect
|
set-intersect
|
||||||
list->set
|
;; list->set
|
||||||
set->list
|
;; set->list
|
||||||
(typed-out [[set-first- : (∀ (X) (→fn (Set X) X))]
|
(typed-out [[set-first- : (∀ (X) (→fn (Set X) X))] set-first]
|
||||||
set-first]
|
[[set-empty?- : (∀ (X) (→fn (Set X) Bool))] set-empty?]
|
||||||
[[set-empty?- : (∀ (X) (→fn (Set X) Bool))]
|
[[set-count- : (∀ (X) (→fn (Set X) Int))] set-count]
|
||||||
set-empty?]))
|
[[set-add- : (∀ (X) (→fn (Set X) X (Set X)))] set-add]
|
||||||
|
[[set-remove- : (∀ (X) (→fn (Set X) X (Set X)))] set-remove]
|
||||||
|
[[set-member?- : (∀ (X) (→fn (Set X) X Bool))] set-member?]
|
||||||
|
[[list->set- : (∀ (X) (→fn (List X) (Set X)))] list->set]
|
||||||
|
[[set->list- : (∀ (X) (→fn (Set X) (List X)))] set->list]
|
||||||
|
))
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
(require (only-in "prim.rkt" Int Bool))
|
(require (only-in "prim.rkt" Int Bool))
|
||||||
(require (only-in "list.rkt" ~List))
|
(require (only-in "list.rkt" ~List List))
|
||||||
|
|
||||||
(require (postfix-in - racket/set))
|
(require (postfix-in - racket/set))
|
||||||
|
|
||||||
|
@ -35,38 +40,6 @@
|
||||||
---------------
|
---------------
|
||||||
[⊢ (#%app- set- e- ...) ⇒ (Set (U τ ...))])
|
[⊢ (#%app- set- e- ...) ⇒ (Set (U τ ...))])
|
||||||
|
|
||||||
(define-typed-syntax (set-count e) ≫
|
|
||||||
[⊢ e ≫ e- ⇒ (~Set _)]
|
|
||||||
#:fail-unless (pure? #'e-) "expression must be pure"
|
|
||||||
----------------------
|
|
||||||
[⊢ (#%app- set-count- e-) ⇒ Int])
|
|
||||||
|
|
||||||
(define-typed-syntax (set-add st v) ≫
|
|
||||||
[⊢ st ≫ st- ⇒ (~Set τs)]
|
|
||||||
#:fail-unless (pure? #'st-) "expression must be pure"
|
|
||||||
[⊢ v ≫ v- ⇒ τv]
|
|
||||||
#:fail-unless (pure? #'v-) "expression must be pure"
|
|
||||||
-------------------------
|
|
||||||
[⊢ (#%app- set-add- st- v-) ⇒ (Set (U τs τv))])
|
|
||||||
|
|
||||||
(define-typed-syntax (set-remove st v) ≫
|
|
||||||
[⊢ st ≫ st- ⇒ (~Set τs)]
|
|
||||||
#:fail-unless (pure? #'st-) "expression must be pure"
|
|
||||||
[⊢ v ≫ v- ⇐ τs]
|
|
||||||
#:fail-unless (pure? #'v-) "expression must be pure"
|
|
||||||
-------------------------
|
|
||||||
[⊢ (#%app- set-remove- st- v-) ⇒ (Set τs)])
|
|
||||||
|
|
||||||
(define-typed-syntax (set-member? st v) ≫
|
|
||||||
[⊢ st ≫ st- ⇒ (~Set τs)]
|
|
||||||
#:fail-unless (pure? #'st-) "expression must be pure"
|
|
||||||
[⊢ v ≫ v- ⇒ τv]
|
|
||||||
#:fail-unless (pure? #'v-) "expression must be pure"
|
|
||||||
#:fail-unless (<: #'τv #'τs)
|
|
||||||
"type mismatch"
|
|
||||||
-------------------------------------
|
|
||||||
[⊢ (#%app- set-member?- st- v-) ⇒ Bool])
|
|
||||||
|
|
||||||
(define-typed-syntax (set-union st0 st ...) ≫
|
(define-typed-syntax (set-union st0 st ...) ≫
|
||||||
[⊢ st0 ≫ st0- ⇒ (~Set τ-st0)]
|
[⊢ st0 ≫ st0- ⇒ (~Set τ-st0)]
|
||||||
#:fail-unless (pure? #'st0-) "expression must be pure"
|
#:fail-unless (pure? #'st0-) "expression must be pure"
|
||||||
|
@ -91,15 +64,3 @@
|
||||||
#:fail-unless (all-pure? #'(st- ...)) "expressions must be pure"
|
#:fail-unless (all-pure? #'(st- ...)) "expressions must be pure"
|
||||||
-------------------------------------
|
-------------------------------------
|
||||||
[⊢ (#%app- set-subtract- st0- st- ...) ⇒ (Set τ-st0)])
|
[⊢ (#%app- set-subtract- st0- st- ...) ⇒ (Set τ-st0)])
|
||||||
|
|
||||||
(define-typed-syntax (list->set l) ≫
|
|
||||||
[⊢ l ≫ l- ⇒ (~List τ)]
|
|
||||||
#:fail-unless (pure? #'l-) "expression must be pure"
|
|
||||||
-----------------------
|
|
||||||
[⊢ (#%app- list->set- l-) ⇒ (Set τ)])
|
|
||||||
|
|
||||||
(define-typed-syntax (set->list s) ≫
|
|
||||||
[⊢ s ≫ s- ⇒ (~Set τ)]
|
|
||||||
#:fail-unless (pure? #'s-) "expression must be pure"
|
|
||||||
-----------------------
|
|
||||||
[⊢ (#%app- set->list- s-) ⇒ (List τ)])
|
|
|
@ -0,0 +1,10 @@
|
||||||
|
/* Useful macros */
|
||||||
|
|
||||||
|
#define ASSERTED(x) (x##_assertions > 0)
|
||||||
|
#define RETRACTED(x) (x##_assertions == 0)
|
||||||
|
#define ASSERT(x) x##_update = x##_update + 1
|
||||||
|
#define RETRACT(x) x##_update = x##_update - 1
|
||||||
|
#define SEND(x) x##_messages = x##_messages + 1
|
||||||
|
|
||||||
|
/* Rest of Program */
|
||||||
|
|
|
@ -0,0 +1,56 @@
|
||||||
|
#lang turnstile
|
||||||
|
|
||||||
|
(provide Observe★
|
||||||
|
RoleNTimes
|
||||||
|
(for-syntax RoleNTimes*))
|
||||||
|
|
||||||
|
(require "core-types.rkt")
|
||||||
|
(require turnstile/typedefs)
|
||||||
|
|
||||||
|
(define-syntax (Observe★ stx)
|
||||||
|
(define star (type-eval #'★/t))
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ TyCons:id)
|
||||||
|
#:do [(define arity? (get-type-arity #'TyCons))]
|
||||||
|
#:when arity?
|
||||||
|
(mk-Observe- (list (reassemble-type #'TyCons (make-list (arity-min arity?) star))))]
|
||||||
|
[(_ t)
|
||||||
|
#:with (~Any/new TyCons τ ...) (type-eval #'t)
|
||||||
|
#:when (reassemblable? #'TyCons)
|
||||||
|
(mk-Observe- (list (reassemble-type #'TyCons (stx-map (lambda (_) star) #'(τ ...)))))]
|
||||||
|
[_
|
||||||
|
(raise-syntax-error #f "Not a type that can automatically be subscribed to" stx)]))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
;; Arity -> Nat
|
||||||
|
(define (arity-min a)
|
||||||
|
(match a
|
||||||
|
[(arity-eq n) n]
|
||||||
|
[(arity-ge n) n])))
|
||||||
|
|
||||||
|
(define-for-syntax (RoleNTimes* n Step behav)
|
||||||
|
(let loop ([i 1])
|
||||||
|
(define nm (format-id behav "step~a" i))
|
||||||
|
(quasisyntax/loc behav
|
||||||
|
(Role (#,nm)
|
||||||
|
#,@(if (= i 1)
|
||||||
|
(list #'(Shares Unit))
|
||||||
|
(list))
|
||||||
|
(Reacts #,(if (= i 1)
|
||||||
|
#'(Asserted Unit)
|
||||||
|
#`(Message #,Step))
|
||||||
|
#,@(if (= i n)
|
||||||
|
(list)
|
||||||
|
(list #`(Sends #,Step))))
|
||||||
|
(Reacts (Message #,Step)
|
||||||
|
(Effs #,behav
|
||||||
|
(Stop #,nm
|
||||||
|
#,@(if (< i n)
|
||||||
|
(if (= i 1)
|
||||||
|
(list #`(Sends #,Step) (loop (add1 i)))
|
||||||
|
(list (loop (add1 i))))
|
||||||
|
(list)))))))))
|
||||||
|
|
||||||
|
(define-syntax-parser RoleNTimes
|
||||||
|
[(_ ~! n:nat Step:type behav:type)
|
||||||
|
(RoleNTimes* (syntax-e #'n) #'Step.norm #'behav.norm)])
|
|
@ -0,0 +1,302 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide serialize-syntax deserialize-syntax)
|
||||||
|
|
||||||
|
(require racket/dict racket/match)
|
||||||
|
|
||||||
|
(struct serialized-syntax (unique-tag table contents) #:prefab)
|
||||||
|
(struct stx-with-props (stx ps) #:prefab)
|
||||||
|
(struct syntax-val (stx) #:prefab)
|
||||||
|
(struct datum-val (d) #:prefab)
|
||||||
|
(struct ref (unique-tag sym) #:prefab)
|
||||||
|
|
||||||
|
;(require racket/pretty)
|
||||||
|
|
||||||
|
(define (serialize-syntax stx)
|
||||||
|
(define unique-tag (gensym))
|
||||||
|
(define table (hasheq))
|
||||||
|
(define dedup-table (hasheq))
|
||||||
|
(define (dedup k f)
|
||||||
|
(if (hash-has-key? dedup-table k)
|
||||||
|
(hash-ref dedup-table k)
|
||||||
|
(let ([res (f)])
|
||||||
|
(set! dedup-table (hash-set dedup-table k res))
|
||||||
|
res)))
|
||||||
|
|
||||||
|
(define (lift! el)
|
||||||
|
(define tag-sym (gensym))
|
||||||
|
(set! table (hash-set table tag-sym el))
|
||||||
|
(ref unique-tag tag-sym))
|
||||||
|
|
||||||
|
(define (build-props! orig-s d)
|
||||||
|
(stx-with-props
|
||||||
|
(datum->syntax orig-s d orig-s #f)
|
||||||
|
(for/list ([k (syntax-property-symbol-keys orig-s)]
|
||||||
|
#:when (syntax-property-preserved? orig-s k))
|
||||||
|
(define val (syntax-property orig-s k))
|
||||||
|
(define serialized-val
|
||||||
|
(if (syntax? val)
|
||||||
|
(syntax-val (serialize-element! val))
|
||||||
|
(datum-val (serialize-element! val #:always-lift? #t))))
|
||||||
|
(cons k serialized-val))))
|
||||||
|
|
||||||
|
(define (serialize-element! el #:always-lift? [always-lift? #f])
|
||||||
|
(dedup
|
||||||
|
el
|
||||||
|
(lambda ()
|
||||||
|
(syntax-map
|
||||||
|
el
|
||||||
|
(lambda (tail? d) d)
|
||||||
|
(lambda (orig-s d)
|
||||||
|
;(when (and always-lift? (not (ref? (hash-ref dedup-table orig-s)))) ; TODO
|
||||||
|
;(error 'dedup "lift error"))
|
||||||
|
(dedup
|
||||||
|
orig-s
|
||||||
|
(lambda ()
|
||||||
|
(if (or always-lift?
|
||||||
|
(ormap (lambda (p) (syntax-property-preserved? orig-s p))
|
||||||
|
(syntax-property-symbol-keys orig-s)))
|
||||||
|
(lift! (build-props! orig-s d))
|
||||||
|
(datum->syntax orig-s d orig-s #f)))))
|
||||||
|
syntax-e))))
|
||||||
|
|
||||||
|
(define top-s (serialize-element! stx))
|
||||||
|
(define res (datum->syntax #f (serialized-syntax unique-tag table top-s)))
|
||||||
|
|
||||||
|
res)
|
||||||
|
|
||||||
|
(define (deserialize-syntax ser)
|
||||||
|
(match (syntax-e ser)
|
||||||
|
[(serialized-syntax unique-tag-stx table-stx contents)
|
||||||
|
(define unique-tag (syntax-e unique-tag-stx))
|
||||||
|
(define table (syntax-e table-stx))
|
||||||
|
(define dedup-table (hasheq))
|
||||||
|
(define (dedup k f)
|
||||||
|
(if (hash-has-key? dedup-table k)
|
||||||
|
(hash-ref dedup-table k)
|
||||||
|
(let ([res (f)])
|
||||||
|
(set! dedup-table (hash-set dedup-table k res))
|
||||||
|
res)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (maybe-syntax-e v)
|
||||||
|
(if (syntax? v) (syntax-e v) v))
|
||||||
|
|
||||||
|
(define (deserialize-stx-with-props ref-sym)
|
||||||
|
(match-define (stx-with-props stx ps) (syntax-e (hash-ref table ref-sym)))
|
||||||
|
(define deserialized-nested-stx (deserialize-element stx))
|
||||||
|
(for/fold ([stx deserialized-nested-stx])
|
||||||
|
([stx-pr (syntax->list ps)])
|
||||||
|
(define pr (syntax-e stx-pr))
|
||||||
|
(define k (syntax-e (car pr)))
|
||||||
|
(define v (syntax-e (cdr pr)))
|
||||||
|
(define prop-val
|
||||||
|
(match v
|
||||||
|
[(syntax-val v)
|
||||||
|
(deserialize-element v)]
|
||||||
|
[(datum-val v)
|
||||||
|
(deserialize-element (syntax->datum v))]))
|
||||||
|
(syntax-property stx k prop-val #t)))
|
||||||
|
|
||||||
|
(define (deserialize-element el)
|
||||||
|
(dedup
|
||||||
|
el
|
||||||
|
(lambda ()
|
||||||
|
(syntax-map
|
||||||
|
el
|
||||||
|
(lambda (tail? d)
|
||||||
|
(match d
|
||||||
|
[(ref tag sym)
|
||||||
|
#:when (equal? (maybe-syntax-e tag) unique-tag)
|
||||||
|
(dedup
|
||||||
|
sym
|
||||||
|
(lambda () (deserialize-stx-with-props (maybe-syntax-e sym))))]
|
||||||
|
[_ d]))
|
||||||
|
(lambda (orig-s d)
|
||||||
|
(dedup
|
||||||
|
orig-s
|
||||||
|
(lambda () (datum->syntax orig-s d orig-s #f))))
|
||||||
|
syntax-e))))
|
||||||
|
|
||||||
|
(define res (deserialize-element contents))
|
||||||
|
res]))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit)
|
||||||
|
|
||||||
|
(define type
|
||||||
|
(syntax-property
|
||||||
|
(syntax-property #'Int ':: #'Type #t)
|
||||||
|
'orig (list #'Int) #t))
|
||||||
|
(define term (syntax-property #`(1 #,(syntax-property #'2 ': type #t)) ': #'Type #t))
|
||||||
|
(define s (serialize-syntax term))
|
||||||
|
(define d (deserialize-syntax s))
|
||||||
|
|
||||||
|
(check-true
|
||||||
|
(bound-identifier=?
|
||||||
|
(syntax-property d ':)
|
||||||
|
#'Type))
|
||||||
|
|
||||||
|
; syntax with properties inside outer syntax with properties.
|
||||||
|
(check-true
|
||||||
|
(bound-identifier=?
|
||||||
|
(syntax-property (syntax-property (cadr (syntax-e d)) ':) '::)
|
||||||
|
#'Type))
|
||||||
|
|
||||||
|
(check-true
|
||||||
|
(bound-identifier=?
|
||||||
|
(syntax-property (cadr (syntax-e d)) ':)
|
||||||
|
#'Int))
|
||||||
|
|
||||||
|
(check-equal?
|
||||||
|
(syntax-position term)
|
||||||
|
(syntax-position d))
|
||||||
|
|
||||||
|
(check-equal?
|
||||||
|
(syntax-position (syntax-property (cadr (syntax-e term)) ':))
|
||||||
|
(syntax-position (syntax-property (cadr (syntax-e d)) ':)))
|
||||||
|
|
||||||
|
(check-equal?
|
||||||
|
(syntax-position (car (syntax-e term)))
|
||||||
|
(syntax-position (car (syntax-e d))))
|
||||||
|
|
||||||
|
; syntax in datum in properties
|
||||||
|
(check-true
|
||||||
|
(bound-identifier=?
|
||||||
|
(car (syntax-property (syntax-property (cadr (syntax-e d)) ':) 'orig))
|
||||||
|
#'Int))
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
;; ----------------------------------------------------------------
|
||||||
|
|
||||||
|
;; syntax-map and datum-map copied from the expander files
|
||||||
|
;; syntax/datum-map.rkt
|
||||||
|
;; syntax/syntax.rkt
|
||||||
|
|
||||||
|
(require racket/fixnum racket/prefab)
|
||||||
|
|
||||||
|
;; `(datum-map v f)` walks over `v`, traversing objects that
|
||||||
|
;; `datum->syntax` traverses to convert content to syntax objects.
|
||||||
|
;;
|
||||||
|
;; `(f tail? d)` is called on each datum `d`, where `tail?`
|
||||||
|
;; indicates that the value is a pair/null in a `cdr` --- so that it
|
||||||
|
;; doesn't need to be wrapped for `datum->syntax`, for example;
|
||||||
|
;; the `tail?` argument is actually #f or a fixnum for a lower bound
|
||||||
|
;; on `cdr`s that have been taken
|
||||||
|
;;
|
||||||
|
;; `gf` is like `f`, but `gf` is used when the argument might be
|
||||||
|
;; syntax; if `gf` is provided, `f` can assume that its argument
|
||||||
|
;; is not syntax
|
||||||
|
;;
|
||||||
|
;; If a `seen` argument is provided, then it should be an `eq?`-based
|
||||||
|
;; hash table, and cycle checking is enabled; when a cycle is
|
||||||
|
;; discovered, the procedure attached to 'cycle-fail in the initial
|
||||||
|
;; table is called
|
||||||
|
;;
|
||||||
|
;; If a `known-pairs` argument is provided, then it should be an
|
||||||
|
;; `eq?`-based hash table to map pairs that can be returned as-is
|
||||||
|
;; in a `tail?` position
|
||||||
|
|
||||||
|
;; The inline version uses `f` only in an application position to
|
||||||
|
;; help avoid allocating a closure. It also covers only the most common
|
||||||
|
;; cases, defering to the general (not inlined) function for other cases.
|
||||||
|
(define (datum-map s f [gf f] [seen #f] [known-pairs #f])
|
||||||
|
(let loop ([tail? #f] [s s] [prev-depth 0])
|
||||||
|
(define depth (fx+ 1 prev-depth)) ; avoid cycle-checking overhead for shallow cases
|
||||||
|
(cond
|
||||||
|
[(and seen (depth . fx> . 32))
|
||||||
|
(datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen known-pairs)]
|
||||||
|
[(null? s) (f tail? s)]
|
||||||
|
[(pair? s)
|
||||||
|
(f tail? (cons (loop #f (car s) depth)
|
||||||
|
(loop 1 (cdr s) depth)))]
|
||||||
|
[(symbol? s) (f #f s)]
|
||||||
|
[(boolean? s) (f #f s)]
|
||||||
|
[(number? s) (f #f s)]
|
||||||
|
[(or (vector? s) (box? s) (prefab-struct-key s) (hash? s))
|
||||||
|
(datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen known-pairs)]
|
||||||
|
[else (gf #f s)])))
|
||||||
|
|
||||||
|
(define (datum-map-slow tail? s f seen known-pairs)
|
||||||
|
(let loop ([tail? tail?] [s s] [prev-seen seen])
|
||||||
|
(define seen
|
||||||
|
(cond
|
||||||
|
[(and prev-seen (datum-has-elements? s))
|
||||||
|
(cond
|
||||||
|
[(hash-ref prev-seen s #f)
|
||||||
|
((hash-ref prev-seen 'cycle-fail) s)]
|
||||||
|
[else (hash-set prev-seen s #t)])]
|
||||||
|
[else prev-seen]))
|
||||||
|
(cond
|
||||||
|
[(null? s) (f tail? s)]
|
||||||
|
[(pair? s)
|
||||||
|
(cond
|
||||||
|
[(and known-pairs
|
||||||
|
tail?
|
||||||
|
(hash-ref known-pairs s #f))
|
||||||
|
s]
|
||||||
|
[else
|
||||||
|
(f tail? (cons (loop #f (car s) seen)
|
||||||
|
(loop (if tail? (fx+ 1 tail?) 1) (cdr s) seen)))])]
|
||||||
|
[(or (symbol? s) (boolean? s) (number? s))
|
||||||
|
(f #f s)]
|
||||||
|
[(vector? s)
|
||||||
|
(f #f (vector->immutable-vector
|
||||||
|
(for/vector #:length (vector-length s) ([e (in-vector s)])
|
||||||
|
(loop #f e seen))))]
|
||||||
|
[(box? s)
|
||||||
|
(f #f (box-immutable (loop #f (unbox s) seen)))]
|
||||||
|
[(immutable-prefab-struct-key s)
|
||||||
|
=> (lambda (key)
|
||||||
|
(f #f
|
||||||
|
(apply make-prefab-struct
|
||||||
|
key
|
||||||
|
(for/list ([e (in-vector (struct->vector s) 1)])
|
||||||
|
(loop #f e seen)))))]
|
||||||
|
[(and (hash? s) (immutable? s))
|
||||||
|
(cond
|
||||||
|
[(hash-eq? s)
|
||||||
|
(f #f
|
||||||
|
(for/hasheq ([(k v) (in-hash s)])
|
||||||
|
(values k (loop #f v seen))))]
|
||||||
|
[(hash-eqv? s)
|
||||||
|
(f #f
|
||||||
|
(for/hasheqv ([(k v) (in-hash s)])
|
||||||
|
(values k (loop #f v seen))))]
|
||||||
|
[else
|
||||||
|
(f #f
|
||||||
|
(for/hash ([(k v) (in-hash s)])
|
||||||
|
(values k (loop #f v seen))))])]
|
||||||
|
[else (f #f s)])))
|
||||||
|
|
||||||
|
(define (datum-has-elements? d)
|
||||||
|
(or (pair? d)
|
||||||
|
(vector? d)
|
||||||
|
(box? d)
|
||||||
|
(immutable-prefab-struct-key d)
|
||||||
|
(and (hash? d) (immutable? d) (positive? (hash-count d)))))
|
||||||
|
|
||||||
|
;; `(syntax-map s f d->s)` walks over `s`:
|
||||||
|
;;
|
||||||
|
;; * `(f tail? d)` is called to each datum `d`, where `tail?`
|
||||||
|
;; indicates that the value is a pair/null in a `cdr` --- so that it
|
||||||
|
;; doesn't need to be wrapped for `datum->syntax`, for example
|
||||||
|
;;
|
||||||
|
;; * `(d->s orig-s d)` is called for each syntax object,
|
||||||
|
;; and the second argument is result of traversing its datum
|
||||||
|
;;
|
||||||
|
;; * the `s-e` function extracts content of a syntax object
|
||||||
|
;;
|
||||||
|
;; The optional `seen` argument is an `eq?`-based immutable hash table
|
||||||
|
;; to detect and reject cycles. See `datum-map`.
|
||||||
|
|
||||||
|
(define (syntax-map s f d->s s-e [seen #f])
|
||||||
|
(let loop ([s s])
|
||||||
|
(datum-map s
|
||||||
|
f
|
||||||
|
(lambda (tail? v)
|
||||||
|
(cond
|
||||||
|
[(syntax? v) (d->s v (loop (s-e v)))]
|
||||||
|
[else (f tail? v)]))
|
||||||
|
seen)))
|
|
@ -0,0 +1,17 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide run/timeout
|
||||||
|
define/timeout)
|
||||||
|
|
||||||
|
(require racket/engine)
|
||||||
|
|
||||||
|
;; (-> A) Real -> (U A Engine)
|
||||||
|
;; run the given thunk in an engine for 'fuel' milliseconds
|
||||||
|
;; if the engine completes, returns the result, otherwise the engine itself
|
||||||
|
(define (run/timeout tnk [fuel 1000])
|
||||||
|
(define e (engine (lambda (p) (tnk))))
|
||||||
|
(define r (engine-run fuel e))
|
||||||
|
(if r (engine-result e) e))
|
||||||
|
|
||||||
|
(define-syntax-rule (define/timeout x e)
|
||||||
|
(define x (run/timeout (lambda () e))))
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,26 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(assertion-struct ping : Ping (v))
|
||||||
|
(assertion-struct pong : Pong (v))
|
||||||
|
|
||||||
|
(assertion-struct flip : Flip (v))
|
||||||
|
(assertion-struct flop : Flop (v))
|
||||||
|
|
||||||
|
(define-type-alias Pinger (Ping Int))
|
||||||
|
(define-type-alias Ponger (U (Ping Int)
|
||||||
|
(Pong Int)
|
||||||
|
(Observe (Ping ★/t))))
|
||||||
|
(define-type-alias PingPong (U Pinger Ponger))
|
||||||
|
|
||||||
|
(define-type-alias Flipper (Flip Int))
|
||||||
|
(define-type-alias Flopper (U (Flip Int)
|
||||||
|
(Flop Int)
|
||||||
|
(Observe (Flip ★/t))))
|
||||||
|
(define-type-alias FlipFlop (U Flipper Flopper))
|
||||||
|
|
||||||
|
(run-ground-dataspace (U PingPong FlipFlop)
|
||||||
|
(spawn Pinger (start-facet _ (assert (ping 5))))
|
||||||
|
(spawn Ponger (start-facet _ (during (ping $v) (assert (pong v)))))
|
||||||
|
|
||||||
|
(spawn Flipper (start-facet _ (assert (flip 8))))
|
||||||
|
(spawn Flopper (start-facet _ (during (flip $v) (assert (flop v))))))
|
|
@ -0,0 +1,22 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
(define-constructor* (trust lvl))
|
||||||
|
|
||||||
|
(check-type (trust 5) : (TrustT Int))
|
||||||
|
|
||||||
|
(define-constructor* (hungry-hippos count appetite)
|
||||||
|
#:with HungryHippos (HungryHipposT Int String))
|
||||||
|
|
||||||
|
(check-type (hungry-hippos 12 "massive") : HungryHippos)
|
||||||
|
|
||||||
|
(define-constructor* (doggy [color : String] [weight : Int]))
|
||||||
|
|
||||||
|
(check-type (doggy "black" 60) : (DoggyT String Int))
|
||||||
|
(check-type (doggy "brown" 45) : Doggy)
|
||||||
|
|
||||||
|
(define-constructor* (leaf))
|
||||||
|
|
||||||
|
(check-type (leaf) : (LeafT))
|
||||||
|
(check-type (leaf) : Leaf)
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(run-ground-dataspace (U)
|
(run-ground-dataspace (U)
|
||||||
(spawn (U)
|
(spawn (U)
|
||||||
|
|
|
@ -1,17 +1,22 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
(define (∀ (ρ) (assert-something! [p : (proc → ★/t #:endpoints (ρ))]))
|
(define (∀ (ρ) (assert-something! [p : (proc → ★/t #:effects (ρ))]))
|
||||||
(p))
|
(p))
|
||||||
|
|
||||||
(define (test-fun)
|
(define (test-fun)
|
||||||
(call/inst assert-something! (lambda () (assert 5))))
|
(call/inst assert-something! (lambda () (assert 5))))
|
||||||
|
|
||||||
|
(check-type test-fun : (proc → ★/t #:effects ((Shares NonZero))))
|
||||||
(check-type test-fun : (proc → ★/t #:endpoints ((Shares Int))))
|
|
||||||
|
|
||||||
(define (test-call/inst-insertion)
|
(define (test-call/inst-insertion)
|
||||||
(assert-something! (lambda () (assert 5))))
|
(assert-something! (lambda () (assert 5))))
|
||||||
|
|
||||||
(check-type test-call/inst-insertion : (proc → ★/t #:endpoints ((Shares Int))))
|
(check-type test-call/inst-insertion : (proc → ★/t #:effects ((Shares NonZero))))
|
||||||
|
|
||||||
|
(define (∀ (ρ) (start-something! [p : (proc → ★/t #:effects (ρ))]))
|
||||||
|
(p))
|
||||||
|
|
||||||
|
(define (test-call-start-something)
|
||||||
|
(start-something! (lambda () (start-facet x (assert 5)))))
|
||||||
|
|
|
@ -0,0 +1,7 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(lambda ()
|
||||||
|
(start-facet x
|
||||||
|
(if #f
|
||||||
|
(assert (tuple 0))
|
||||||
|
(assert (tuple 1)))))
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,9 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
;; TODO - currently fails with a racket error. Is that OK?
|
||||||
|
;; (ideally, this would fail with a better error message)
|
||||||
|
(typecheck-fail
|
||||||
|
(let ([x (define y 5)])
|
||||||
|
(add1 1)))
|
|
@ -0,0 +1,9 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
(check-type (for/list ([x (for/list ([y (list 1 2 3)])
|
||||||
|
y)])
|
||||||
|
x)
|
||||||
|
: (List Int)
|
||||||
|
⇒ (list 1 2 3))
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
@ -9,7 +9,7 @@
|
||||||
: Int
|
: Int
|
||||||
⇒ 0)
|
⇒ 0)
|
||||||
|
|
||||||
(check-type (for/fold ([x 0])
|
(check-type (for/fold ([x : Int 0])
|
||||||
([y (list 1 2 3)])
|
([y (list 1 2 3)])
|
||||||
y)
|
y)
|
||||||
: Int
|
: Int
|
||||||
|
@ -20,13 +20,13 @@
|
||||||
(define inventory0 (list (tuple "The Wind in the Willows" 5)
|
(define inventory0 (list (tuple "The Wind in the Willows" 5)
|
||||||
(tuple "Catch 22" 2)
|
(tuple "Catch 22" 2)
|
||||||
(tuple "Candide" 33)))
|
(tuple "Candide" 33)))
|
||||||
(check-type (for/fold ([stock 0])
|
(check-type (for/fold ([stock : Int 0])
|
||||||
([item inventory0])
|
([item inventory0])
|
||||||
(select 1 item))
|
(select 1 item))
|
||||||
: Int
|
: Int
|
||||||
⇒ 33)
|
⇒ 33)
|
||||||
|
|
||||||
(check-type (for/fold ([stock 0])
|
(check-type (for/fold ([stock : Int 0])
|
||||||
([item inventory0])
|
([item inventory0])
|
||||||
(if (equal? "Catch 22" (select 0 item))
|
(if (equal? "Catch 22" (select 0 item))
|
||||||
(select 1 item)
|
(select 1 item)
|
||||||
|
@ -36,7 +36,7 @@
|
||||||
|
|
||||||
(define (lookup [title : String]
|
(define (lookup [title : String]
|
||||||
[inv : Inventory] -> Int)
|
[inv : Inventory] -> Int)
|
||||||
(for/fold ([stock 0])
|
(for/fold ([stock : Int 0])
|
||||||
([item inv])
|
([item inv])
|
||||||
(if (equal? title (select 0 item))
|
(if (equal? title (select 0 item))
|
||||||
(select 1 item)
|
(select 1 item)
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/syndicate/roles
|
#lang typed/syndicate
|
||||||
|
|
||||||
(require rackunit/turnstile)
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue