remove implementations of non-late-neg projections from bunch of combinators
This commit is contained in:
Robby Findler
parent
7d02f4c7b1
commit
8776ab7686
|
|
@ -128,32 +128,7 @@
|
|||
[fail-proc (fail-proc neg-party)]
|
||||
[else
|
||||
(late-neg-proj (unbox val) neg-party)
|
||||
val]))))
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(check-box/c ctc val blame)
|
||||
(((contract-projection (base-box/c-content-w ctc)) blame) (unbox val))
|
||||
val)))))
|
||||
|
||||
(define (ho-projection box-wrapper)
|
||||
(λ (ctc)
|
||||
(let ([elem-w-ctc (base-box/c-content-w ctc)]
|
||||
[elem-r-ctc (base-box/c-content-r ctc)]
|
||||
[immutable (base-box/c-immutable ctc)])
|
||||
(λ (blame)
|
||||
(let ([pos-elem-r-proj ((contract-projection elem-r-ctc) blame)]
|
||||
[neg-elem-w-proj ((contract-projection elem-w-ctc) (blame-swap blame))])
|
||||
(λ (val)
|
||||
(check-box/c ctc val blame)
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(box-immutable (pos-elem-r-proj (unbox val)))
|
||||
(box-wrapper val
|
||||
(λ (b v) (pos-elem-r-proj v)) ; unbox-proc
|
||||
(λ (b v) (neg-elem-w-proj v)) ; set-proc
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))))))))
|
||||
val]))))))
|
||||
|
||||
(define (ho-late-neg-projection chaperone/impersonate-box)
|
||||
(λ (ctc)
|
||||
|
|
@ -188,8 +163,7 @@
|
|||
#:name box/c-name
|
||||
#:first-order box/c-first-order
|
||||
#:stronger box/c-stronger
|
||||
#:late-neg-projection (ho-late-neg-projection chaperone-box)
|
||||
#:projection (ho-projection chaperone-box)))
|
||||
#:late-neg-projection (ho-late-neg-projection chaperone-box)))
|
||||
|
||||
(define-struct (impersonator-box/c base-box/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -198,8 +172,7 @@
|
|||
#:name box/c-name
|
||||
#:first-order box/c-first-order
|
||||
#:stronger box/c-stronger
|
||||
#:late-neg-projection (ho-late-neg-projection impersonate-box)
|
||||
#:projection (ho-projection impersonate-box)))
|
||||
#:late-neg-projection (ho-late-neg-projection impersonate-box)))
|
||||
|
||||
(define-syntax (wrap-box/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -110,17 +110,6 @@
|
|||
(let ([tests (map contract-first-order (base-and/c-ctcs ctc))])
|
||||
(λ (x) (for/and ([test (in-list tests)]) (test x)))))
|
||||
|
||||
(define (and-proj ctc)
|
||||
(let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))])
|
||||
(lambda (blame)
|
||||
(define projs
|
||||
(for/list ([c (in-list mk-pos-projs)]
|
||||
[n (in-naturals 1)])
|
||||
(c (blame-add-context blame (format "the ~a conjunct of" (n->th n))))))
|
||||
(for/fold ([proj (car projs)])
|
||||
([p (in-list (cdr projs))])
|
||||
(λ (v) (p (proj v)))))))
|
||||
|
||||
(define (late-neg-and-proj ctc)
|
||||
(define mk-pos-projs (map get/build-late-neg-projection (base-and/c-ctcs ctc)))
|
||||
(λ (blame)
|
||||
|
|
@ -137,22 +126,6 @@
|
|||
(loop (cdr projs)
|
||||
((car projs) val neg-party))])))))
|
||||
|
||||
(define (first-order-and-proj ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(let loop ([predicates (first-order-and/c-predicates ctc)]
|
||||
[ctcs (base-and/c-ctcs ctc)])
|
||||
(cond
|
||||
[(null? predicates) val]
|
||||
[else
|
||||
(cond
|
||||
[((car predicates) val)
|
||||
(loop (cdr predicates) (cdr ctcs))]
|
||||
[else
|
||||
(define ctc1-proj (contract-projection (car ctcs)))
|
||||
(define new-blame (blame-add-context blame "an and/c case of"))
|
||||
((ctc1-proj new-blame) val)])])))))
|
||||
|
||||
(define (first-order-late-neg-and-proj ctc)
|
||||
(define predicates (first-order-and/c-predicates ctc))
|
||||
(define blame-accepters (map get/build-late-neg-projection (base-and/c-ctcs ctc)))
|
||||
|
|
@ -270,7 +243,6 @@
|
|||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection first-order-and-proj
|
||||
#:late-neg-projection first-order-late-neg-and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
|
|
@ -280,7 +252,6 @@
|
|||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection and-proj
|
||||
#:late-neg-projection late-neg-and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
|
|
@ -290,7 +261,6 @@
|
|||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection and-proj
|
||||
#:late-neg-projection late-neg-and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
|
|
@ -674,47 +644,6 @@
|
|||
[else
|
||||
(elem-fo? v)])))]))
|
||||
|
||||
(define (listof-projection ctc)
|
||||
(define elem-proj (contract-projection (listof-ctc-elem-c ctc)))
|
||||
(define pred? (if (pe-listof-ctc? ctc)
|
||||
list?
|
||||
non-empty-list?))
|
||||
(λ (blame)
|
||||
(define elem-proj+blame (elem-proj (blame-add-listof-context blame)))
|
||||
(cond
|
||||
[(flat-listof-ctc? ctc)
|
||||
(if (im-listof-ctc? ctc)
|
||||
(λ (val)
|
||||
(let loop ([val val])
|
||||
(cond
|
||||
[(pair? val)
|
||||
(elem-proj+blame (car val))
|
||||
(loop (cdr val))]
|
||||
[else
|
||||
(elem-proj+blame val)]))
|
||||
val)
|
||||
(λ (val)
|
||||
(if (pred? val)
|
||||
(begin
|
||||
(for ([x (in-list val)])
|
||||
(elem-proj+blame x))
|
||||
val)
|
||||
(raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))]
|
||||
[else
|
||||
(if (im-listof-ctc? ctc)
|
||||
(λ (val)
|
||||
(let loop ([val val])
|
||||
(cond
|
||||
[(pair? val)
|
||||
(cons (elem-proj+blame (car val))
|
||||
(loop (cdr val)))]
|
||||
[else (elem-proj+blame val)])))
|
||||
(λ (val)
|
||||
(if (pred? val)
|
||||
(for/list ([x (in-list val)])
|
||||
(elem-proj+blame x))
|
||||
(raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))])))
|
||||
|
||||
(define (listof-late-neg-projection ctc)
|
||||
(define elem-proj (get/build-late-neg-projection (listof-ctc-elem-c ctc)))
|
||||
(define pred? (if (pe-listof-ctc? ctc)
|
||||
|
|
@ -762,7 +691,6 @@
|
|||
(build-flat-contract-property
|
||||
#:name list-name
|
||||
#:first-order list-fo-check
|
||||
#:projection listof-projection
|
||||
#:late-neg-projection listof-late-neg-projection
|
||||
#:generate listof-generate
|
||||
#:exercise listof-exercise
|
||||
|
|
@ -772,7 +700,6 @@
|
|||
(build-chaperone-contract-property
|
||||
#:name list-name
|
||||
#:first-order list-fo-check
|
||||
#:projection listof-projection
|
||||
#:late-neg-projection listof-late-neg-projection
|
||||
#:generate listof-generate
|
||||
#:exercise listof-exercise
|
||||
|
|
@ -782,7 +709,6 @@
|
|||
(build-contract-property
|
||||
#:name list-name
|
||||
#:first-order list-fo-check
|
||||
#:projection listof-projection
|
||||
#:late-neg-projection listof-late-neg-projection
|
||||
#:generate listof-generate
|
||||
#:exercise listof-exercise
|
||||
|
|
@ -877,7 +803,6 @@
|
|||
(define (blame-add-car-context blame) (blame-add-context blame "the car of"))
|
||||
(define (blame-add-cdr-context blame) (blame-add-context blame "the cdr of"))
|
||||
|
||||
|
||||
(define ((cons/c-late-neg-ho-check combine) ctc)
|
||||
(define ctc-car (the-cons/c-hd-ctc ctc))
|
||||
(define ctc-cdr (the-cons/c-tl-ctc ctc))
|
||||
|
|
@ -893,19 +818,6 @@
|
|||
(car-p (car v) neg-party)
|
||||
(cdr-p (cdr v) neg-party)))))
|
||||
|
||||
(define ((cons/c-ho-check combine) ctc)
|
||||
(define ctc-car (the-cons/c-hd-ctc ctc))
|
||||
(define ctc-cdr (the-cons/c-tl-ctc ctc))
|
||||
(define car-proj (contract-projection ctc-car))
|
||||
(define cdr-proj (contract-projection ctc-cdr))
|
||||
(λ (blame)
|
||||
(let ([car-p (car-proj (blame-add-car-context blame))]
|
||||
[cdr-p (cdr-proj (blame-add-cdr-context blame))])
|
||||
(λ (v)
|
||||
(unless (pair? v)
|
||||
(raise-not-cons-blame-error blame v))
|
||||
(combine v (car-p (car v)) (cdr-p (cdr v)))))))
|
||||
|
||||
(define (cons/c-first-order ctc)
|
||||
(define ctc-car (the-cons/c-hd-ctc ctc))
|
||||
(define ctc-cdr (the-cons/c-tl-ctc ctc))
|
||||
|
|
@ -962,7 +874,6 @@
|
|||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) v))
|
||||
#:projection (cons/c-ho-check (λ (v a d) v))
|
||||
#:name cons/c-name
|
||||
#:first-order cons/c-first-order
|
||||
#:stronger cons/c-stronger?
|
||||
|
|
@ -973,7 +884,6 @@
|
|||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d)))
|
||||
#:projection (cons/c-ho-check (λ (v a d) (cons a d)))
|
||||
#:name cons/c-name
|
||||
#:first-order cons/c-first-order
|
||||
#:stronger cons/c-stronger?
|
||||
|
|
@ -984,7 +894,6 @@
|
|||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d)))
|
||||
#:projection (cons/c-ho-check (λ (v a d) (cons a d)))
|
||||
#:name cons/c-name
|
||||
#:first-order cons/c-first-order
|
||||
#:stronger cons/c-stronger?
|
||||
|
|
@ -1267,38 +1176,8 @@
|
|||
val
|
||||
'(expected "a list" given: "~e")
|
||||
val)]))))
|
||||
#:projection
|
||||
(lambda (c)
|
||||
(lambda (blame)
|
||||
(lambda (x)
|
||||
(unless (list? x)
|
||||
(raise-blame-error blame x '(expected "a list" given: "~e") x))
|
||||
(let* ([args (generic-list/c-args c)]
|
||||
[expected (length args)]
|
||||
[actual (length x)])
|
||||
(expected-a-list-of-len x actual expected blame)
|
||||
(for ([arg/c (in-list args)] [v (in-list x)] [i (in-naturals 1)])
|
||||
(((contract-projection arg/c)
|
||||
(add-list-context blame i))
|
||||
v))
|
||||
x))))
|
||||
#:list-contract? (λ (c) #t)))
|
||||
|
||||
(define (list/c-chaperone/other-projection c)
|
||||
(define args (map contract-projection (generic-list/c-args c)))
|
||||
(define expected (length args))
|
||||
(λ (blame)
|
||||
(define projs (for/list ([arg/c (in-list args)]
|
||||
[i (in-naturals 1)])
|
||||
(arg/c (add-list-context blame i))))
|
||||
(λ (x)
|
||||
(unless (list? x) (expected-a-list x blame))
|
||||
(define actual (length x))
|
||||
(expected-a-list-of-len x actual expected blame #:missing-party #f)
|
||||
(for/list ([item (in-list x)]
|
||||
[proj (in-list projs)])
|
||||
(proj item)))))
|
||||
|
||||
(define (expected-a-list x blame #:missing-party [missing-party #f])
|
||||
(raise-blame-error blame #:missing-party missing-party
|
||||
x '(expected: "a list" given: "~e") x))
|
||||
|
|
@ -1363,7 +1242,6 @@
|
|||
#:generate list/c-generate
|
||||
#:exercise list/c-exercise
|
||||
#:stronger list/c-stronger
|
||||
#:projection list/c-chaperone/other-projection
|
||||
#:late-neg-projection list/c-chaperone/other-late-neg-projection
|
||||
#:list-contract? (λ (c) #t)))
|
||||
|
||||
|
|
@ -1376,7 +1254,6 @@
|
|||
#:generate list/c-generate
|
||||
#:exercise list/c-exercise
|
||||
#:stronger list/c-stronger
|
||||
#:projection list/c-chaperone/other-projection
|
||||
#:late-neg-projection list/c-chaperone/other-late-neg-projection
|
||||
#:list-contract? (λ (c) #t)))
|
||||
|
||||
|
|
@ -1477,25 +1354,6 @@
|
|||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(let* ([in-proc (contract-projection (parameter/c-in ctc))]
|
||||
[out-proc (contract-projection (parameter/c-out ctc))])
|
||||
(λ (blame)
|
||||
(define blame/c (blame-add-context blame "the parameter of"))
|
||||
(define (add-profiling f)
|
||||
(λ (x) (with-contract-continuation-mark (cons blame #f) (f x))))
|
||||
(define partial-neg-contract (add-profiling (in-proc (blame-swap blame/c))))
|
||||
(define partial-pos-contract (add-profiling (out-proc blame/c)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(parameter? val)
|
||||
(make-derived-parameter
|
||||
val
|
||||
partial-neg-contract
|
||||
partial-pos-contract)]
|
||||
[else
|
||||
(raise-blame-error blame val '(expected "a parameter"))])))))
|
||||
#:late-neg-projection
|
||||
(λ (ctc)
|
||||
(define in-proc (get/build-late-neg-projection (parameter/c-in ctc)))
|
||||
|
|
@ -1563,12 +1421,9 @@
|
|||
n))
|
||||
(make-procedure-arity-includes/c n))
|
||||
|
||||
(define (get-any-projection c) any-projection)
|
||||
(define (any-projection b) any-function)
|
||||
(define (any-function x) x)
|
||||
|
||||
(define (get-any? c) any?)
|
||||
(define (any? x) #t)
|
||||
(define any/c-blame->neg-party-fn (λ (blame) any/c-neg-party-fn))
|
||||
(define any/c-neg-party-fn (λ (val neg-party) val))
|
||||
|
||||
(define (random-any/c env fuel)
|
||||
|
|
@ -1608,8 +1463,7 @@
|
|||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection get-any-projection
|
||||
#:late-neg-projection (λ (ctc) (λ (blame) any/c-neg-party-fn))
|
||||
#:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn)
|
||||
#:stronger (λ (this that) (any/c? that))
|
||||
#:name (λ (ctc) 'any/c)
|
||||
#:generate (λ (ctc)
|
||||
|
|
@ -1623,16 +1477,6 @@
|
|||
(define-syntax (any stx)
|
||||
(raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx))
|
||||
|
||||
(define (none-curried-proj ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
'("~s accepts no values" given: "~e")
|
||||
(none/c-name ctc)
|
||||
val))))
|
||||
|
||||
(define (((none-curried-late-neg-proj ctc) blame) val neg-party)
|
||||
(raise-blame-error
|
||||
blame #:missing-party neg-party
|
||||
|
|
@ -1646,7 +1490,6 @@
|
|||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection none-curried-proj
|
||||
#:late-neg-projection none-curried-late-neg-proj
|
||||
#:stronger (λ (this that) #t)
|
||||
#:name (λ (ctc) (none/c-name ctc))
|
||||
|
|
@ -1680,42 +1523,6 @@
|
|||
(list '#:call/cc) (base-prompt-tag/c-call/ccs ctc))))
|
||||
|
||||
;; build a projection for prompt tags
|
||||
(define ((prompt-tag/c-proj chaperone?) ctc)
|
||||
(define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag))
|
||||
(define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure))
|
||||
(define ho-projs
|
||||
(map contract-projection (base-prompt-tag/c-ctcs ctc)))
|
||||
(define call/cc-projs
|
||||
(map contract-projection (base-prompt-tag/c-call/ccs ctc)))
|
||||
(λ (blame)
|
||||
(define (make-proj projs swap?)
|
||||
(λ vs
|
||||
(define vs2 (for/list ([proj projs] [v vs])
|
||||
((proj (if swap? (blame-swap blame) blame)) v)))
|
||||
(apply values vs2)))
|
||||
;; prompt/abort projections
|
||||
(define proj1 (make-proj ho-projs #f))
|
||||
(define proj2 (make-proj ho-projs #t))
|
||||
;; call/cc projections
|
||||
(define call/cc-guard (make-proj call/cc-projs #f))
|
||||
(define call/cc-proxy
|
||||
(λ (f)
|
||||
(proc-proxy
|
||||
f
|
||||
(λ args
|
||||
(apply values (make-proj call/cc-projs #t) args)))))
|
||||
;; now do the actual wrapping
|
||||
(λ (val)
|
||||
(unless (contract-first-order-passes? ctc val)
|
||||
(raise-blame-error
|
||||
blame val
|
||||
'(expected: "~s" given: "~e")
|
||||
(contract-name ctc)
|
||||
val))
|
||||
(proxy val proj1 proj2 call/cc-guard call/cc-proxy
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))))
|
||||
|
||||
(define ((prompt-tag/c-late-neg-proj chaperone?) ctc)
|
||||
(define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag))
|
||||
(define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure))
|
||||
|
|
@ -1779,7 +1586,6 @@
|
|||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:late-neg-projection (prompt-tag/c-late-neg-proj #t)
|
||||
#:projection (prompt-tag/c-proj #t)
|
||||
#:first-order (λ (ctc) continuation-prompt-tag?)
|
||||
#:stronger prompt-tag/c-stronger?
|
||||
#:name prompt-tag/c-name))
|
||||
|
|
@ -1789,7 +1595,6 @@
|
|||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:late-neg-projection (prompt-tag/c-late-neg-proj #f)
|
||||
#:projection (prompt-tag/c-proj #f)
|
||||
#:first-order (λ (ctc) continuation-prompt-tag?)
|
||||
#:stronger prompt-tag/c-stronger?
|
||||
#:name prompt-tag/c-name))
|
||||
|
|
@ -1808,23 +1613,6 @@
|
|||
'continuation-mark-key/c
|
||||
(base-continuation-mark-key/c-ctc ctc)))
|
||||
|
||||
(define ((continuation-mark-key/c-proj proxy) ctc)
|
||||
(define ho-proj
|
||||
(contract-projection (base-continuation-mark-key/c-ctc ctc)))
|
||||
(λ (blame)
|
||||
(define proj1 (ho-proj blame))
|
||||
(define proj2 (ho-proj (blame-swap blame)))
|
||||
(λ (val)
|
||||
(unless (contract-first-order-passes? ctc val)
|
||||
(raise-blame-error
|
||||
blame val
|
||||
'(expected: "~s" given: "~e")
|
||||
(contract-name ctc)
|
||||
val))
|
||||
(proxy val proj1 proj2
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))))
|
||||
|
||||
(define ((continuation-mark-key/c-late-neg-proj proxy) ctc)
|
||||
(define ho-proj
|
||||
(get/build-late-neg-projection (base-continuation-mark-key/c-ctc ctc)))
|
||||
|
|
@ -1864,7 +1652,6 @@
|
|||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:late-neg-projection (continuation-mark-key/c-late-neg-proj chaperone-continuation-mark-key)
|
||||
#:projection (continuation-mark-key/c-proj chaperone-continuation-mark-key)
|
||||
#:first-order (λ (ctc) continuation-mark-key?)
|
||||
#:stronger continuation-mark-key/c-stronger?
|
||||
#:name continuation-mark-key/c-name))
|
||||
|
|
@ -1876,7 +1663,6 @@
|
|||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:late-neg-projection (continuation-mark-key/c-late-neg-proj impersonate-continuation-mark-key)
|
||||
#:projection (continuation-mark-key/c-proj impersonate-continuation-mark-key)
|
||||
#:first-order (λ (ctc) continuation-mark-key?)
|
||||
#:stronger continuation-mark-key/c-stronger?
|
||||
#:name continuation-mark-key/c-name))
|
||||
|
|
@ -1960,23 +1746,6 @@
|
|||
'channel/c
|
||||
(base-channel/c-ctc ctc)))
|
||||
|
||||
(define ((channel/c-proj proxy) ctc)
|
||||
(define ho-proj
|
||||
(contract-projection (base-channel/c-ctc ctc)))
|
||||
(λ (blame)
|
||||
(define proj1 (λ (ch) (values ch (λ (v) ((ho-proj blame) v)))))
|
||||
(define proj2 (λ (ch v) ((ho-proj (blame-swap blame)) v)))
|
||||
(λ (val)
|
||||
(unless (contract-first-order-passes? ctc val)
|
||||
(raise-blame-error
|
||||
blame val
|
||||
'(expected: "~s" given: "~e")
|
||||
(contract-name ctc)
|
||||
val))
|
||||
(proxy val proj1 proj2
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))))
|
||||
|
||||
(define ((channel/c-late-neg-proj proxy) ctc)
|
||||
(define ho-proj
|
||||
(get/build-late-neg-projection (base-channel/c-ctc ctc)))
|
||||
|
|
@ -2016,7 +1785,6 @@
|
|||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:late-neg-projection (channel/c-late-neg-proj chaperone-channel)
|
||||
#:projection (channel/c-proj chaperone-channel)
|
||||
#:first-order channel/c-first-order
|
||||
#:stronger channel/c-stronger?
|
||||
#:name channel/c-name))
|
||||
|
|
@ -2027,7 +1795,6 @@
|
|||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:late-neg-projection (channel/c-late-neg-proj impersonate-channel)
|
||||
#:projection (channel/c-proj impersonate-channel)
|
||||
#:first-order channel/c-first-order
|
||||
#:stronger channel/c-stronger?
|
||||
#:name channel/c-name))
|
||||
|
|
|
|||
|
|
@ -72,17 +72,6 @@
|
|||
(let ([r (loop (car rst) (cdr rst))])
|
||||
(λ (x) (or (fst-pred x) (r x))))])))]))
|
||||
|
||||
(define (single-or/c-projection ctc)
|
||||
(let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
|
||||
[pred (single-or/c-pred ctc)])
|
||||
(λ (blame)
|
||||
(define partial-contract
|
||||
(c-proc (blame-add-or-context blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else (partial-contract val)])))))
|
||||
|
||||
(define (single-or/c-late-neg-projection ctc)
|
||||
(define c-proj (get/build-late-neg-projection (single-or/c-ho-ctc ctc)))
|
||||
(define c-first-order (contract-first-order (single-or/c-ho-ctc ctc)))
|
||||
|
|
@ -218,7 +207,6 @@
|
|||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:late-neg-projection single-or/c-late-neg-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
|
|
@ -233,7 +221,6 @@
|
|||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:late-neg-projection single-or/c-late-neg-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
|
|
@ -244,52 +231,6 @@
|
|||
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
|
||||
#:list-contract? single-or/c-list-contract?))
|
||||
|
||||
(define (multi-or/c-proj ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
[c-procs (map (λ (x) (contract-projection x)) ho-contracts)]
|
||||
[first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
|
||||
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
|
||||
(λ (blame)
|
||||
(define disj-blame (blame-add-or-context blame))
|
||||
(define partial-contracts
|
||||
(for/list ([c-proc (in-list c-procs)])
|
||||
(c-proc disj-blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts ho-contracts]
|
||||
[candidate-proc #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-none-or-matched blame val #f))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(raise-blame-error blame val
|
||||
'("two of the clauses in the or/c might both match: ~s and ~s"
|
||||
given:
|
||||
"~e")
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
(car procs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
candidate-proc
|
||||
candidate-contract)]))])))))
|
||||
|
||||
(define (multi-or/c-late-neg-proj ctc)
|
||||
(define ho-contracts (multi-or/c-ho-ctcs ctc))
|
||||
(define c-projs (map get/build-late-neg-projection ho-contracts))
|
||||
|
|
@ -376,7 +317,6 @@
|
|||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:late-neg-projection multi-or/c-late-neg-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
|
|
@ -391,7 +331,6 @@
|
|||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:late-neg-projection multi-or/c-late-neg-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
|
|
@ -453,31 +392,6 @@
|
|||
|
||||
(define-struct (flat-first-or/c flat-or/c) ())
|
||||
|
||||
(define (first-or/c-proj ctc)
|
||||
(define contracts (base-first-or/c-ctcs ctc))
|
||||
(define c-procs (map (λ (x) (contract-projection x)) contracts))
|
||||
(define first-order-checks (map (λ (x) (contract-first-order x)) contracts))
|
||||
(λ (blame)
|
||||
(define disj-blame (blame-add-ior-context blame))
|
||||
(define partial-contracts
|
||||
(for/list ([c-proc (in-list c-procs)])
|
||||
(c-proc disj-blame)))
|
||||
(λ (val)
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts contracts])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(raise-none-ior-matched blame val #f)]
|
||||
[else
|
||||
(cond
|
||||
[((car checks) val)
|
||||
((car procs) val)]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts))])])))))
|
||||
|
||||
(define (first-or/c-late-neg-proj ctc)
|
||||
(define ho-contracts (base-first-or/c-ctcs ctc))
|
||||
(define c-projs (map get/build-late-neg-projection ho-contracts))
|
||||
|
|
@ -538,7 +452,6 @@
|
|||
(define-struct (chaperone-first-or/c base-first-or/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection first-or/c-proj
|
||||
#:late-neg-projection first-or/c-late-neg-proj
|
||||
#:name first-or/c-name
|
||||
#:first-order first-or/c-first-order
|
||||
|
|
@ -549,7 +462,6 @@
|
|||
(define-struct (impersonator-first-or/c base-first-or/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection first-or/c-proj
|
||||
#:late-neg-projection first-or/c-late-neg-proj
|
||||
#:name first-or/c-name
|
||||
#:first-order first-or/c-first-order
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user