First pass at field/c
Logic mostly dupicated from parameter/c
This commit is contained in:
parent
22f5c47d30
commit
e1f42d5d4f
|
@ -9,6 +9,7 @@
|
||||||
forever
|
forever
|
||||||
|
|
||||||
field
|
field
|
||||||
|
field/c
|
||||||
assert
|
assert
|
||||||
stop-when
|
stop-when
|
||||||
on-start
|
on-start
|
||||||
|
@ -60,6 +61,7 @@
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require racket/contract)
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
|
@ -97,6 +99,32 @@
|
||||||
(dataflow-record-damage! (actor-state-field-dataflow (current-actor-state)) desc)
|
(dataflow-record-damage! (actor-state-field-dataflow (current-actor-state)) desc)
|
||||||
(set-box! (get-field-box desc) v)]))
|
(set-box! (get-field-box desc) v)]))
|
||||||
|
|
||||||
|
(define (make-field-proxy field guard wrap)
|
||||||
|
(case-lambda
|
||||||
|
[() (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)))
|
||||||
|
(lambda (f neg-party)
|
||||||
|
(define proj-with-blame (lambda (x) (proj x neg-party)))
|
||||||
|
(cond
|
||||||
|
[(field-handle? f)
|
||||||
|
(make-field-proxy f proj-with-blame proj-with-blame)]
|
||||||
|
[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)
|
||||||
previous-knowledge ;; AssertionSet
|
previous-knowledge ;; AssertionSet
|
||||||
|
|
Loading…
Reference in New Issue