syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Implement field/c using a struct rather than make-contract 

Asumu suggested that using a struct with the contract property is
generally preferred.
This commit is contained in:
Sam Caldwell 2016-07-19 17:49:45 -04:00
parent 9cf12a381e
commit e20f87adba
1 changed files with 32 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
racket/syndicate/actor.rkt
View File

@ -112,27 +112,38 @@
[() (wrap (field))]
[(x) (field (guard x))]))
(define (field/c ctc)
(let ([ctc (coerce-contract 'field/c ctc)])
(make-contract #:name (build-compound-type-name 'field/c ctc)
#:first-order
(lambda (f) (and (field-handle? f)
(ctc (f))))
#:late-neg-projection
(lambda (blame)
(define proc (get/build-late-neg-projection ctc))
(define blame/c (blame-add-context blame "the field of"))
(define proj (proc (blame-swap blame/c)))
(define proj-pos (lambda (x) (proj x (blame-positive blame))))
(lambda (f neg-party)
(define proj-neg (lambda (x) (proj x neg-party)))
(cond
[(field-handle? f)
(make-field-proxy f proj-neg proj-pos)]
[else (raise-blame-error blame/c
#:missing-party neg-party
f
'(expected: "a field"))]))))))
(define/subexpression-pos-prop (field/c ctc)
(make-field/c (coerce-contract 'field/c ctc)))
(define-struct field/c (ctc)
#:property prop:custom-write custom-write-property-proc
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:name
(lambda (ctc) (build-compound-type-name 'field/c (field/c-ctc ctc)))
#:first-order
(lambda (ctc)
(let ([ctc (field/c-ctc ctc)])
(lambda (f) (and (field-handle? f)
(ctc (f))))))
#:late-neg-projection
(lambda (ctc)
(let ([ctc (field/c-ctc ctc)])
(lambda (blame)
(define proc (get/build-late-neg-projection ctc))
(define blame/c (blame-add-context blame "the field of"))
(define proj (proc (blame-swap blame/c)))
(define proj-pos (lambda (x) (proj x (blame-positive blame))))
(lambda (f neg-party)
(define proj-neg (lambda (x) (proj x neg-party)))
(cond
[(field-handle? f)
(make-field-proxy f proj-neg proj-pos)]
[else (raise-blame-error blame/c
#:missing-party neg-party
f
'(expected: "a field"))])))))))
(struct actor-state (mux ;; Mux
facets ;; (Hash FID Facet)