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