suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

tweak and clean up the contract combinators api

Browse Source 
- uniformly remove the extra layers of calls to unknown functions for
  chapereone-of?  checks that make sure that chaperone contracts are
  well-behaved (put those checks only in contracts that are created
  outside racket/contract)

- clean up and simplify how missing projection functions are created
  (val-first vs late-neg vs the regular ones)

- add some logging to more accurately tell when late-neg projections
  aren't being used

- port the contract combinator that ->m uses to use late-neg

- port the </c combinator to use late-neg
This commit is contained in:
Robby Findler 2015-12-09 16:41:38 -06:00
parent 5a01b97400
commit 3d7d906cc1
14 changed files with 1057 additions and 488 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -1992,6 +1992,9 @@ first-order test fails, and produces the value unchanged otherwise.
The @racket[val-first-proj] is like @racket[late-neg-proj], except with The @racket[val-first-proj] is like @racket[late-neg-proj], except with
an extra layer of currying. an extra layer of currying.
At least one of the @racket[late-neg-proj], @racket[proj],
@racket[val-first-proj], or @racket[first-order] must be non-@racket[#f].
The projection arguments (@racket[late-neg-proj], @racket[proj], and The projection arguments (@racket[late-neg-proj], @racket[proj], and
@racket[val-first-proj]) must be in sync with the @racket[test] argument. @racket[val-first-proj]) must be in sync with the @racket[test] argument.
In particular, if the test argument returns @racket[#f] for some value, In particular, if the test argument returns @racket[#f] for some value,
@ -2106,6 +2109,30 @@ contracts. The error messages assume that the function named by
@history[#:added "6.1.1.5"] @history[#:added "6.1.1.5"]
} }
@defproc[(get/build-late-neg-projection [c contract?])
(-> contract? blame? (-> any/c any/c any/c))]{
Returns the @racket[_late-neg] projection for @racket[c].
If @racket[c] does not have a @racket[_late-neg] contract,
then this function uses the original projection for it
and logs a warning to the @racket['racket/contract] logger.
See @racket[make-contract] for more details.
@history[#:added "6.2.900.11"]
}
@defparam[skip-projection-wrapper? wrap? boolean? #:value #f]{
The functions @racket[make-chaperone-contract] and
@racket[build-chaperone-contract-property] wrap their
arguments to ensure that the result of the projections
are chaperones of the input. This layer of wrapping can,
in some cases, introduce unwanted overhead into contract
checking. If this parameter's value is @racket[#t]
during the dynamic extent of the call to either of those
functions, the wrapping (and thus the checks) are skipped.
}
@subsection{Blame Objects} @subsection{Blame Objects}
@defproc[(blame? [x any/c]) boolean?]{ @defproc[(blame? [x any/c]) boolean?]{
@ -2526,6 +2553,9 @@ whose values will be generated by this process; and @racket[is-flat-contract?],
which is used by @racket[flat-contract?] to determine if this contract which is used by @racket[flat-contract?] to determine if this contract
accepts only @racket[list?]s. accepts only @racket[list?]s.
At least one of the @racket[late-neg-proj], @racket[proj],
@racket[val-first-proj], or @racket[first-order] must be non-@racket[#f].
These accessors are passed as (optional) keyword arguments to These accessors are passed as (optional) keyword arguments to
@racket[build-contract-property], and are applied to instances of the @racket[build-contract-property], and are applied to instances of the
appropriate structure type by the contract system. Their results are used appropriate structure type by the contract system. Their results are used

354
pkgs/racket-test/tests/racket/contract/make-contract.rkt
View File

@ -134,6 +134,52 @@
'(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) '(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
exn:fail?) exn:fail?)
(contract-eval
'(define val-first-proj:bad-prime-box-list/c
(let* ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))]
[wrap-box (λ (blame b) (box (unbox b)))])
(make-chaperone-contract
#:name 'bad-prime-box-list/c
#:first-order (λ (v) (and (list? v) (andmap box? v)))
#:val-first-projection
(λ (blame)
(λ (v)
(λ (neg-party)
(unless (and (list? v) (andmap box? v))
(raise-blame-error blame v
#:missing-party neg-party
"expected list of boxes, got ~v" v))
(map (λ (b) (wrap-box blame b)) v))))))))
(contract-error-test
'contract-error-test6
'(contract val-first-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
exn:fail?)
(contract-eval
'(define late-neg-proj:bad-prime-box-list/c
(let* ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))]
[wrap-box (λ (blame b) (box (unbox b)))])
(make-chaperone-contract
#:name 'bad-prime-box-list/c
#:first-order (λ (v) (and (list? v) (andmap box? v)))
#:late-neg-projection
(λ (blame)
(λ (v neg-party)
(unless (and (list? v) (andmap box? v))
(raise-blame-error blame v
"expected list of boxes, got ~v" v))
(map (λ (b) (wrap-box blame b)) v)))))))
(contract-error-test
'contract-error-test7
'(contract late-neg-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
exn:fail?)
(test/pos-blame (test/pos-blame
'build-chaperone-contract-property1 'build-chaperone-contract-property1
'(let () '(let ()
@ -156,6 +202,88 @@
(((contract-projection (val-first-none)) (((contract-projection (val-first-none))
(make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t)) (make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
5))) 5)))
(contract-eval
'(define prop:late-neg-proj:bad-prime-box-list/c
(let* ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))]
[wrap-box (λ (blame b) (box (unbox b)))])
(struct ctc ()
#:property
prop:chaperone-contract
(build-chaperone-contract-property
#:name (λ (c) 'bad-prime-box-list/c)
#:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v))))
#:late-neg-projection
(λ (c)
(λ (blame)
(λ (v neg-party)
(unless (and (list? v) (andmap box? v))
(raise-blame-error blame v #:missing-party neg-party
"expected list of boxes, got ~v" v))
(map (λ (b) (wrap-box blame b)) v))))))
(ctc))))
(contract-error-test
'contract-error-test8
'(contract prop:late-neg-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
exn:fail?)
(contract-eval
'(define prop:val-first-proj:bad-prime-box-list/c
(let* ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))]
[wrap-box (λ (blame b) (box (unbox b)))])
(struct ctc ()
#:property
prop:chaperone-contract
(build-chaperone-contract-property
#:name (λ (c) 'bad-prime-box-list/c)
#:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v))))
#:val-first-projection
(λ (c)
(λ (blame)
(λ (v)
(λ (neg-party)
(unless (and (list? v) (andmap box? v))
(raise-blame-error blame v #:missing-party neg-party
"expected list of boxes, got ~v" v))
(map (λ (b) (wrap-box blame b)) v)))))))
(ctc))))
(contract-error-test
'contract-error-test9
'(contract prop:val-first-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
exn:fail?)
(contract-eval
'(define prop:proj:bad-prime-box-list/c
(let* ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))]
[wrap-box (λ (blame b) (box (unbox b)))])
(struct ctc ()
#:property
prop:chaperone-contract
(build-chaperone-contract-property
#:name (λ (c) 'bad-prime-box-list/c)
#:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v))))
#:projection
(λ (c)
(λ (blame)
(λ (v)
(unless (and (list? v) (andmap box? v))
(raise-blame-error blame v
"expected list of boxes, got ~v" v))
(map (λ (b) (wrap-box blame b)) v))))))
(ctc))))
(contract-error-test
'contract-error-test10
'(contract prop:proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
exn:fail?)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -226,4 +354,228 @@
(test/spec-passed/result (test/spec-passed/result
'make-flat-contract-bad-6 'make-flat-contract-bad-6
'(chaperone-contract? proj:prime-list/c) '(chaperone-contract? proj:prime-list/c)
#t)) #t)
(contract-eval
'(define val-first-proj:prime-list/c
(let ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))])
(make-flat-contract
#:name 'prime-list/c
#:first-order (λ (v) (and (list? v) (andmap prime? v)))
#:val-first-projection
(λ (b)
(λ (v)
(λ (neg-party)
(unless (and (list? v) (andmap prime? v))
(raise-blame-error b v #:missing-party neg-party
"expected prime list, got ~v" v))
(map values v))))))))
(test/spec-passed/result
'make-flat-contract-bad-7
'(contract val-first-proj:prime-list/c (list 2 3 5 7) 'pos 'neg)
(list 2 3 5 7))
(test/pos-blame
'make-flat-contract-bad-8
'(contract val-first-proj:prime-list/c (list 2 3 4 5) 'pos 'neg))
(test/spec-passed/result
'make-flat-contract-bad-9
'(let ([l (list 2 3 5 7)])
(eq? l (contract val-first-proj:prime-list/c l 'pos 'neg)))
#t)
(ctest #t contract? val-first-proj:prime-list/c)
(ctest #t flat-contract? val-first-proj:prime-list/c)
(test/spec-passed/result
'make-flat-contract-bad-10
'(chaperone-contract? val-first-proj:prime-list/c)
#t)
(contract-eval
'(define late-neg-proj:prime-list/c
(let ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))])
(make-flat-contract
#:name 'prime-list/c
#:first-order (λ (v) (and (list? v) (andmap prime? v)))
#:late-neg-projection
(λ (b)
(λ (v neg-party)
(unless (and (list? v) (andmap prime? v))
(raise-blame-error b v #:missing-party neg-party "expected prime list, got ~v" v))
(map values v)))))))
(test/spec-passed/result
'make-flat-contract-bad-11
'(contract late-neg-proj:prime-list/c (list 2 3 5 7) 'pos 'neg)
(list 2 3 5 7))
(test/pos-blame
'make-flat-contract-bad-12
'(contract late-neg-proj:prime-list/c (list 2 3 4 5) 'pos 'neg))
(test/spec-passed/result
'make-flat-contract-bad-13
'(let ([l (list 2 3 5 7)])
(eq? l (contract late-neg-proj:prime-list/c l 'pos 'neg)))
#t)
(ctest #t contract? late-neg-proj:prime-list/c)
(ctest #t flat-contract? late-neg-proj:prime-list/c)
(test/spec-passed/result
'make-flat-contract-bad-14
'(chaperone-contract? late-neg-proj:prime-list/c)
#t)
(contract-eval
'(define prop:proj:prime-list/c
(let ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))])
(struct ctc ()
#:property
prop:flat-contract
(build-flat-contract-property
#:name (λ (c) 'prime-list/c)
#:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v))))
#:projection
(λ (c)
(λ (b)
(λ (v)
(unless (and (list? v) (andmap prime? v))
(raise-blame-error b v "expected prime list, got ~v" v))
(map values v))))))
(ctc))))
(test/spec-passed/result
'make-flat-contract-bad-15
'(contract prop:proj:prime-list/c (list 2 3 5 7) 'pos 'neg)
(list 2 3 5 7))
(test/pos-blame
'make-flat-contract-bad-16
'(contract prop:proj:prime-list/c (list 2 3 4 5) 'pos 'neg))
(test/spec-passed/result
'make-flat-contract-bad-17
'(let ([l (list 2 3 5 7)])
(eq? l (contract prop:proj:prime-list/c l 'pos 'neg)))
#t)
(ctest #t contract? prop:proj:prime-list/c)
(ctest #t flat-contract? prop:proj:prime-list/c)
(test/spec-passed/result
'make-flat-contract-bad-18
'(chaperone-contract? prop:proj:prime-list/c)
#t)
(contract-eval
'(define prop:val-first-proj:prime-list/c
(let ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))])
(struct ctc ()
#:property
prop:flat-contract
(build-flat-contract-property
#:name (λ (c) 'prime-list/c)
#:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v))))
#:val-first-projection
(λ (c)
(λ (b)
(λ (v)
(λ (neg-party)
(unless (and (list? v) (andmap prime? v))
(raise-blame-error b v
#:missing-party neg-party
"expected prime list, got ~v" v))
(map values v)))))))
(ctc))))
(test/spec-passed/result
'make-flat-contract-bad-19
'(contract prop:val-first-proj:prime-list/c (list 2 3 5 7) 'pos 'neg)
(list 2 3 5 7))
(test/pos-blame
'make-flat-contract-bad-20
'(contract prop:val-first-proj:prime-list/c (list 2 3 4 5) 'pos 'neg))
(test/spec-passed/result
'make-flat-contract-bad-21
'(let ([l (list 2 3 5 7)])
(eq? l (contract prop:val-first-proj:prime-list/c l 'pos 'neg)))
#t)
(ctest #t contract? prop:val-first-proj:prime-list/c)
(ctest #t flat-contract? prop:val-first-proj:prime-list/c)
(test/spec-passed/result
'make-flat-contract-bad-22
'(chaperone-contract? prop:val-first-proj:prime-list/c)
#t)
(contract-eval
'(define prop:late-neg-proj:prime-list/c
(let ([prime? (λ (n)
(for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
(not (= (remainder n m) 0))))])
(struct ctc ()
#:property
prop:flat-contract
(build-flat-contract-property
#:name (λ (c) 'prime-list/c)
#:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v))))
#:late-neg-projection
(λ (c)
(λ (b)
(λ (v neg-party)
(unless (and (list? v) (andmap prime? v))
(raise-blame-error b v
#:missing-party neg-party
"expected prime list, got ~v" v))
(map values v))))))
(ctc))))
(test/spec-passed/result
'make-flat-contract-bad-23
'(contract prop:late-neg-proj:prime-list/c (list 2 3 5 7) 'pos 'neg)
(list 2 3 5 7))
(test/pos-blame
'make-flat-contract-bad-24
'(contract prop:late-neg-proj:prime-list/c (list 2 3 4 5) 'pos 'neg))
(test/spec-passed/result
'make-flat-contract-bad-25
'(let ([l (list 2 3 5 7)])
(eq? l (contract prop:late-neg-proj:prime-list/c l 'pos 'neg)))
#t)
(ctest #t contract? prop:late-neg-proj:prime-list/c)
(ctest #t flat-contract? prop:late-neg-proj:prime-list/c)
(test/spec-passed/result
'make-flat-contract-bad-26
'(chaperone-contract? prop:late-neg-proj:prime-list/c)
#t))

182
racket/collects/racket/contract/combinator.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require "private/prop.rkt" (require "private/prop.rkt"
(prefix-in : "private/prop.rkt")
"private/guts.rkt" "private/guts.rkt"
"private/blame.rkt") "private/blame.rkt")
@ -12,7 +13,11 @@
contract-struct-stronger? contract-struct-stronger?
contract-struct? contract-struct?
chaperone-contract-struct? chaperone-contract-struct?
flat-contract-struct?) flat-contract-struct?
make-chaperone-contract
make-flat-contract
build-chaperone-contract-property
build-flat-contract-property)
(except-out (all-from-out "private/guts.rkt") (except-out (all-from-out "private/guts.rkt")
check-flat-contract check-flat-contract
@ -21,4 +26,177 @@
has-contract? has-contract?
value-contract) value-contract)
(except-out (all-from-out "private/blame.rkt") make-blame)) (except-out (all-from-out "private/blame.rkt") make-blame)
(rename-out [-make-chaperone-contract make-chaperone-contract]
[-make-flat-contract make-flat-contract]
[-build-chaperone-contract-property build-chaperone-contract-property]
[-build-flat-contract-property build-flat-contract-property])
skip-projection-wrapper?)
(define skip-projection-wrapper? (make-parameter #f))
(define (maybe-add-wrapper f x)
(cond
[(and x (not (skip-projection-wrapper?)))
(f x)]
[else x]))
(define -make-chaperone-contract
(let ([make-chaperone-contract
(λ (#:name [name 'anonymous-chaperone-contract]
#:first-order [first-order (λ (x) #t)]
#:late-neg-projection [late-neg-projection #f]
#:val-first-projection [val-first-projection #f]
#:projection [projection #f]
#:stronger [stronger #f]
#:list-contract? [is-list-contract #f])
(:make-chaperone-contract
#:name name
#:first-order first-order
#:late-neg-projection
(maybe-add-wrapper add-late-neg-chaperone-check late-neg-projection)
#:val-first-projection
(maybe-add-wrapper add-val-first-chaperone-check val-first-projection)
#:projection
(maybe-add-wrapper add-projection-chaperone-check projection)
#:stronger stronger
#:list-contract? is-list-contract))])
make-chaperone-contract))
(define -build-chaperone-contract-property
(let ()
(define (build-chaperone-contract-property
#:name [get-name (λ (c) 'anonymous-chaperone-contract)]
#:first-order [get-first-order (λ (c) (λ (x) #t))]
#:val-first-projection [val-first-proj #f]
#:late-neg-projection [late-neg-proj #f]
#:projection [get-projection #f]
#:stronger [stronger #f]
#:generate [generate #f]
#:exercise [exercise #f])
(:build-chaperone-contract-property
#:name get-name
#:first-order get-first-order
#:val-first-projection
(maybe-add-wrapper add-prop-val-first-chaperone-check val-first-proj)
#:late-neg-projection
(maybe-add-wrapper add-prop-late-neg-chaperone-check late-neg-proj)
#:projection
(maybe-add-wrapper add-prop-chaperone-check get-projection)
#:stronger stronger
#:generate generate
#:exercise exercise))
build-chaperone-contract-property))
(define (add-prop-late-neg-chaperone-check get-late-neg)
(λ (c)
(add-late-neg-chaperone-check (get-late-neg c))))
(define (add-late-neg-chaperone-check accepts-blame)
(λ (b)
(define accepts-val-and-np (accepts-blame b))
(λ (x neg-party)
(check-and-signal x
(accepts-val-and-np x neg-party)
'make-chaperone-contract::late-neg-projection))))
(define (add-prop-val-first-chaperone-check get)
(λ (c)
(add-val-first-chaperone-check (get c))))
(define (add-val-first-chaperone-check vfp)
(λ (b)
(define x-acceptor (vfp b))
(λ (x)
(define neg-acceptor (x-acceptor x))
(λ (neg-party)
(check-and-signal x
(neg-acceptor neg-party)
'make-chaperone-contract::late-neg-projection)))))
(define (add-prop-chaperone-check get)
(λ (c)
(add-projection-chaperone-check (get c))))
(define (add-projection-chaperone-check proj)
(λ (b)
(define x-acceptor (proj b))
(λ (x)
(check-and-signal x (x-acceptor x)
'make-chaperone-contract::projection))))
(define (check-and-signal val chapd-val who)
(unless (chaperone-of? chapd-val val)
(raise-result-error who
(format "chaperone-of ~e" val)
chapd-val))
chapd-val)
(define -make-flat-contract
(let ([make-flat-contract
(λ (#:name [name 'anonymous-chaperone-contract]
#:first-order [first-order (λ (x) #t)]
#:late-neg-projection [late-neg-projection #f]
#:val-first-projection [val-first-projection #f]
#:projection [projection #f]
#:stronger [stronger #f]
#:list-contract? [is-list-contract #f])
(:make-flat-contract
#:name name
#:first-order first-order
#:late-neg-projection (force-late-neg-eq late-neg-projection)
#:val-first-projection (force-val-first-eq val-first-projection)
#:projection (force-projection-eq projection)
#:stronger stronger
#:list-contract? is-list-contract))])
make-flat-contract))
(define -build-flat-contract-property
(let ([build-flat-contract-property
(λ (#:name [name (λ (c) 'anonymous-chaperone-contract)]
#:first-order [first-order (λ (c) (λ (x) #t))]
#:late-neg-projection [late-neg-projection #f]
#:val-first-projection [val-first-projection #f]
#:projection [projection #f]
#:stronger [stronger #f]
#:list-contract? [is-list-contract #f])
(:build-flat-contract-property
#:name name
#:first-order first-order
#:late-neg-projection
(and late-neg-projection (λ (c) (force-late-neg-eq (late-neg-projection c))))
#:val-first-projection
(and val-first-projection (λ (c) (force-val-first-eq (val-first-projection c))))
#:projection
(and projection (λ (c) (force-projection-eq (projection c))))
#:stronger stronger
#:list-contract? is-list-contract))])
build-flat-contract-property))
(define (force-late-neg-eq accepts-blame)
(and accepts-blame
(λ (b)
(define accepts-val-and-np (accepts-blame b))
(λ (x neg-party)
(accepts-val-and-np x neg-party)
x))))
(define (force-val-first-eq vfp)
(and vfp
(λ (b)
(define x-acceptor (vfp b))
(λ (x)
(define neg-acceptor (x-acceptor x))
(λ (neg-party)
(neg-acceptor neg-party)
x)))))
(define (force-projection-eq proj)
(and proj
(λ (b)
(define x-acceptor (proj b))
(λ (x)
(x-acceptor x)
x))))

8
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -87,11 +87,11 @@
(->i-mandatory-args ctc) (->i-mandatory-args ctc)
(->i-mandatory-kwds ctc) (->i-mandatory-kwds ctc)
(->i-opt-kwds ctc) (->i-opt-kwds ctc)
blame) blame #f)
(check-procedure val mtd? (check-procedure val mtd?
(->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-args ctc) (->i-opt-args ctc)
(->i-mandatory-kwds ctc) (->i-opt-kwds ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc)
blame))) blame #f)))
ctc ctc
blame swapped-blame ;; used by the #:pre and #:post checking blame swapped-blame ;; used by the #:pre and #:post checking
(append blames (append blames
@ -313,8 +313,8 @@
[opt-kwds (->i-opt-kwds ctc)]) [opt-kwds (->i-opt-kwds ctc)])
(λ (val) (λ (val)
(if has-rest (if has-rest
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f) (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f #f)
(check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f))))) (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f)))))
#:exercise exercise->i #:exercise exercise->i
#:stronger (λ (this that) (eq? this that)))) ;; WRONG #:stronger (λ (this that) (eq? this that)))) ;; WRONG

6
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -308,7 +308,7 @@
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([basic-lambda-name basic-lambda]) (let ([basic-lambda-name basic-lambda])
(arrow:arity-checking-wrapper val (arrow:arity-checking-wrapper val
(blame-add-missing-party blame neg-party) blame neg-party
basic-lambda-name basic-lambda-name
void void
#,min-method-arity #,min-method-arity
@ -321,7 +321,7 @@
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda]) (let ([kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val (arrow:arity-checking-wrapper val
(blame-add-missing-party blame neg-party) blame neg-party
void void
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
@ -335,7 +335,7 @@
(let ([basic-lambda-name basic-lambda] (let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda]) [kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val (arrow:arity-checking-wrapper val
(blame-add-missing-party blame neg-party) blame neg-party
basic-lambda-name basic-lambda-name
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity

81
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -911,7 +911,6 @@
(for/list ([kwd (in-list (append mandatory-keywords optional-keywords))] (for/list ([kwd (in-list (append mandatory-keywords optional-keywords))]
[kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))]) [kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))])
(cons kwd kwd-proj)))) (cons kwd kwd-proj))))
(define complete-blame (blame-add-missing-party blame neg-party))
(define interposition-proc (define interposition-proc
(make-keyword-procedure (make-keyword-procedure
@ -936,7 +935,8 @@
(loop (cdr args) (cdr projs)))]))) (loop (cdr args) (cdr projs)))])))
(define (result-checker . results) (define (result-checker . results)
(unless (= rng-len (length results)) (unless (= rng-len (length results))
(arrow:bad-number-of-results complete-blame f rng-len results)) (arrow:bad-number-of-results (blame-add-missing-party blame neg-party)
f rng-len results))
(apply (apply
values values
(for/list ([res (in-list results)] (for/list ([res (in-list results)]
@ -952,7 +952,7 @@
(cons result-checker args-dealt-with) (cons result-checker args-dealt-with)
args-dealt-with))))) args-dealt-with)))))
(arrow:arity-checking-wrapper f complete-blame (arrow:arity-checking-wrapper f blame neg-party
interposition-proc interposition-proc interposition-proc interposition-proc
min-arity max-arity min-arity max-arity
min-arity max-arity min-arity max-arity
@ -1176,44 +1176,43 @@
(base->-plus-one-arity-function ->stct) (base->-plus-one-arity-function ->stct)
(base->-chaperone-constructor ->stct) (base->-chaperone-constructor ->stct)
#t))) #t)))
(parameterize ([skip-projection-wrapper? #t]) (build-X-property
(build-X-property #:name base->-name
#:name base->-name #:first-order ->-first-order
#:first-order ->-first-order #:projection
#:projection (λ (this)
(λ (this) (define cthis (val-first-proj this))
(define cthis (val-first-proj this)) (λ (blame)
(λ (blame) (define cblame (cthis blame))
(define cblame (cthis blame)) (λ (val)
(λ (val) ((cblame val) #f))))
((cblame val) #f)))) #:stronger
#:stronger (λ (this that)
(λ (this that) (and (base->? that)
(and (base->? that) (= (length (base->-doms that))
(= (length (base->-doms that)) (length (base->-doms this)))
(length (base->-doms this))) (= (base->-min-arity this) (base->-min-arity that))
(= (base->-min-arity this) (base->-min-arity that)) (andmap contract-stronger? (base->-doms that) (base->-doms this))
(andmap contract-stronger? (base->-doms that) (base->-doms this)) (= (length (base->-kwd-infos this))
(= (length (base->-kwd-infos this)) (length (base->-kwd-infos that)))
(length (base->-kwd-infos that))) (for/and ([this-kwd-info (base->-kwd-infos this)]
(for/and ([this-kwd-info (base->-kwd-infos this)] [that-kwd-info (base->-kwd-infos that)])
[that-kwd-info (base->-kwd-infos that)]) (and (equal? (kwd-info-kwd this-kwd-info)
(and (equal? (kwd-info-kwd this-kwd-info) (kwd-info-kwd that-kwd-info))
(kwd-info-kwd that-kwd-info)) (contract-stronger? (kwd-info-ctc that-kwd-info)
(contract-stronger? (kwd-info-ctc that-kwd-info) (kwd-info-ctc this-kwd-info))))
(kwd-info-ctc this-kwd-info)))) (if (base->-rngs this)
(if (base->-rngs this) (and (base->-rngs that)
(and (base->-rngs that) (andmap contract-stronger? (base->-rngs this) (base->-rngs that)))
(andmap contract-stronger? (base->-rngs this) (base->-rngs that))) (not (base->-rngs that)))
(not (base->-rngs that))) (not (base->-pre? this))
(not (base->-pre? this)) (not (base->-pre? that))
(not (base->-pre? that)) (not (base->-post? this))
(not (base->-post? this)) (not (base->-post? that))))
(not (base->-post? that)))) #:generate ->-generate
#:generate ->-generate #:exercise ->-exercise
#:exercise ->-exercise #:val-first-projection val-first-proj
#:val-first-projection val-first-proj #:late-neg-projection late-neg-proj))
#:late-neg-projection late-neg-proj)))
(define-struct (-> base->) () (define-struct (-> base->) ()
#:property #:property

341
racket/collects/racket/contract/private/arrow.rkt
View File

@ -87,46 +87,46 @@
[(p-app-x ...) (generate-temporaries #'(rngs ...))] [(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (get/build-late-neg-projection rngs-x)] ...)
(define (projection wrapper get-ctc) (define (projection wrapper get-ctc)
(λ (orig-blame) (λ (orig-blame)
(define ctc (get-ctc)) (define ctc (get-ctc))
(let ([rng-blame (blame-add-range-context orig-blame)]) (let ([rng-blame (blame-add-range-context orig-blame)])
(let* ([p-app-x (proj-x rng-blame)] ... (let* ([p-app-x (proj-x rng-blame)] ...)
[res-checker (λ (res-x ...) (values/drop (p-app-x res-x) ...))]) (λ (val neg-party)
(λ (val) (check-is-a-procedure orig-blame neg-party val)
(check-is-a-procedure orig-blame val) (define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...))
(wrapper (wrapper
val val
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (λ (kwds kwd-vals . args)
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key orig-blame contract-continuation-mark-key (cons orig-blame neg-party)
#,(check-tail-contract #,(check-tail-contract
#'(p-app-x ...) #'(p-app-x ...)
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args))))) (λ (s) #`(apply values #,@s kwd-vals args)))))
(λ args (λ args
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key orig-blame contract-continuation-mark-key (cons orig-blame neg-party)
#,(check-tail-contract #,(check-tail-contract
#'(p-app-x ...) #'(p-app-x ...)
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s args)))))) (λ (s) #`(apply values #,@s args))))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:application-mark impersonator-prop:application-mark
(cons contract-key (list p-app-x ...)))))))) (cons contract-key (list p-app-x ...))))))))
(make-unconstrained-domain-> (list rngs-x ...) (make-unconstrained-domain-> (list rngs-x ...)
projection))))])) projection))))]))
(define (check-is-a-procedure orig-blame val) (define (check-is-a-procedure orig-blame neg-party val)
(unless (procedure? val) (unless (procedure? val)
(raise-blame-error orig-blame (raise-blame-error orig-blame #:missing-party neg-party
val val
'(expected: "a procedure" given: "~v") '(expected: "a procedure" given: "~v")
val))) val)))
(define (make-unconstrained-domain-> ctcs projection) (define (make-unconstrained-domain-> ctcs late-neg-projection)
(define name (define name
(apply build-compound-type-name 'unconstrained-domain-> (apply build-compound-type-name 'unconstrained-domain->
(map contract-name ctcs))) (map contract-name ctcs)))
@ -134,11 +134,11 @@
(if (andmap chaperone-contract? ctcs) (if (andmap chaperone-contract? ctcs)
(make-chaperone-contract (make-chaperone-contract
#:name name #:name name
#:projection (projection chaperone-procedure (λ () ctc)) #:late-neg-projection (late-neg-projection chaperone-procedure (λ () ctc))
#:first-order procedure?) #:first-order procedure?)
(make-contract (make-contract
#:name name #:name name
#:projection (projection impersonate-procedure (λ () ctc)) #:late-neg-projection (late-neg-projection impersonate-procedure (λ () ctc))
#:first-order procedure?))) #:first-order procedure?)))
ctc) ctc)
@ -201,18 +201,25 @@
(loop (cdr accepted) req-kwds (cdr opt-kwds))] (loop (cdr accepted) req-kwds (cdr opt-kwds))]
[else #f]))]))) [else #f]))])))
(define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs) (define-for-syntax (create-chaperone blame neg-party val pre post this-args
doms opt-doms dom-rest req-kwds opt-kwds
rngs)
(with-syntax ([blame blame] (with-syntax ([blame blame]
[neg-party neg-party]
[val val]) [val val])
(with-syntax ([(pre ...) (with-syntax ([(pre ...)
(if pre (if pre
(list #`(unless #,pre (list #`(unless #,pre
(raise-blame-error (blame-swap blame) val "#:pre condition"))) (raise-blame-error
(blame-swap blame) #:missing-party neg-party
val "#:pre condition")))
null)] null)]
[(post ...) [(post ...)
(if post (if post
(list #`(unless #,post (list #`(unless #,post
(raise-blame-error blame val "#:post condition"))) (raise-blame-error
blame #:missing-party neg-party
val "#:post condition")))
null)]) null)])
(with-syntax ([(this-param ...) this-args] (with-syntax ([(this-param ...) this-args]
[(dom-ctc ...) doms] [(dom-ctc ...) doms]
@ -240,12 +247,12 @@
(if (and (pair? rngs) (null? (cdr rngs))) (if (and (pair? rngs) (null? (cdr rngs)))
(with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))] (with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))]
[name (car (syntax->list #'(rng-x ...)))]) [name (car (syntax->list #'(rng-x ...)))])
#'(proj name)) #'(proj name neg-party))
#'(values/drop (rng-ctc rng-x) ...))]) #'(values/drop (rng-ctc rng-x neg-party) ...))])
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key blame contract-continuation-mark-key (cons blame neg-party)
(let () (let ()
post ... post ...
rng-results))] rng-results))]
@ -267,13 +274,15 @@
[else [else
#'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])] #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])]
[opt+rest-uses [opt+rest-uses
(for/fold ([i (if dom-rest #'(rest-ctc rest-x) #'null)]) (for/fold ([i (if dom-rest #'(rest-ctc rest-x neg-party) #'null)])
([o (in-list (reverse (syntax->list #'([opt-dom-ctc opt-dom-x] ...))))]) ([o (in-list (reverse
(syntax->list
#'((opt-dom-ctc opt-dom-x) ...))))])
(let* ([l (syntax->list o)] (let* ([l (syntax->list o)]
[c (car l)] [c (car l)]
[x (cadr l)]) [x (cadr l)])
#`(let ([r #,i]) #`(let ([r #,i])
(if (eq? unspecified-dom #,x) r (cons (#,c #,x) r)))))] (if (eq? unspecified-dom #,x) r (cons (#,c #,x neg-party) r)))))]
[(kwd-param ...) [(kwd-param ...)
(apply append (apply append
(map list (map list
@ -282,9 +291,12 @@
[kwd-stx [kwd-stx
(let* ([req-stxs (let* ([req-stxs
(map (λ (s) (λ (r) #`(cons #,s #,r))) (map (λ (s) (λ (r) #`(cons #,s #,r)))
(syntax->list #'((req-kwd-ctc req-kwd-x) ...)))] (syntax->list #'((req-kwd-ctc req-kwd-x neg-party) ...)))]
[opt-stxs [opt-stxs
(map (λ (x c) (λ (r) #`(let ([r #,r]) (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r))))) (map (λ (x c) (λ (r) #`(let ([r #,r])
(if (eq? unspecified-dom #,x)
r
(cons (#,c #,x neg-party) r)))))
(syntax->list #'(opt-kwd-x ...)) (syntax->list #'(opt-kwd-x ...))
(syntax->list #'(opt-kwd-ctc ...)))] (syntax->list #'(opt-kwd-ctc ...)))]
[reqs (map cons req-keywords req-stxs)] [reqs (map cons req-keywords req-stxs)]
@ -301,16 +313,23 @@
[basic-return [basic-return
(let ([inner-stx-gen (let ([inner-stx-gen
(if need-apply-values? (if need-apply-values?
(λ (s) #`(apply values #,@s this-param ... (dom-ctc dom-x) ... opt+rest-uses)) (λ (s) #`(apply values #,@s this-param ...
(λ (s) #`(values/drop #,@s this-param ... (dom-ctc dom-x) ...)))]) (dom-ctc dom-x neg-party) ... opt+rest-uses))
(λ (s) #`(values/drop #,@s this-param ...
(dom-ctc dom-x neg-party) ...)))])
(if no-rng-checking? (if no-rng-checking?
(inner-stx-gen #'()) (inner-stx-gen #'())
(check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) inner-stx-gen)))] (check-tail-contract #'(rng-ctc ...)
#'(rng-checker-name ...)
inner-stx-gen)))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply-values? (if need-apply-values?
(λ (s k) #`(apply values #,@s #,@k this-param ... (dom-ctc dom-x) ... opt+rest-uses)) (λ (s k) #`(apply values #,@s #,@k this-param ...
(λ (s k) #`(values/drop #,@s #,@k this-param ... (dom-ctc dom-x) ...)))] (dom-ctc dom-x neg-party) ...
opt+rest-uses))
(λ (s k) #`(values/drop #,@s #,@k this-param ...
(dom-ctc dom-x neg-party) ...)))]
[outer-stx-gen [outer-stx-gen
(if (null? req-keywords) (if (null? req-keywords)
(λ (s) (λ (s)
@ -335,13 +354,13 @@
;; noticeable in my measurements so far. ;; noticeable in my measurements so far.
;; - stamourv ;; - stamourv
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key blame contract-continuation-mark-key (cons blame neg-party)
(let () (let ()
pre ... basic-return)))] pre ... basic-return)))]
[kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params [kwd-lambda #`(λ kwd-lam-params
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key blame contract-continuation-mark-key (cons blame neg-party)
(let () (let ()
pre ... kwd-return)))]) pre ... kwd-return)))])
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))]) (with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
@ -349,7 +368,7 @@
[(and (null? req-keywords) (null? opt-keywords)) [(and (null? req-keywords) (null? opt-keywords))
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda]) (let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame (arity-checking-wrapper val blame neg-party
basic-lambda-name basic-lambda-name
void void
#,min-method-arity #,min-method-arity
@ -361,7 +380,7 @@
[(pair? req-keywords) [(pair? req-keywords)
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda]) (let ([kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame (arity-checking-wrapper val blame neg-party
void void
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
@ -374,7 +393,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda] (let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda]) [kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame (arity-checking-wrapper val blame neg-party
basic-lambda-name basic-lambda-name
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
@ -385,7 +404,7 @@
'(opt-kwd ...))))]))))))))))) '(opt-kwd ...))))])))))))))))
;; should we pass both the basic-lambda and the kwd-lambda? ;; should we pass both the basic-lambda and the kwd-lambda?
(define (arity-checking-wrapper val blame basic-lambda kwd-lambda (define (arity-checking-wrapper val blame neg-party basic-lambda kwd-lambda
min-method-arity max-method-arity min-arity max-arity min-method-arity max-method-arity min-arity max-arity
req-kwd opt-kwd) req-kwd opt-kwd)
;; should not build this unless we are in the 'else' case (and maybe not at all) ;; should not build this unless we are in the 'else' case (and maybe not at all)
@ -404,27 +423,28 @@
(define kwd-checker (define kwd-checker
(if (and (null? req-kwd) (null? opt-kwd)) (if (and (null? req-kwd) (null? opt-kwd))
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(raise-no-keywords-arg blame val kwds)) (raise-no-keywords-arg blame #:missing-party neg-party val kwds))
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key blame contract-continuation-mark-key (cons blame neg-party)
(let () (let ()
(define args-len (length args)) (define args-len (length args))
(unless (valid-number-of-args? args) (unless (valid-number-of-args? args)
(raise-wrong-number-of-args-error (raise-wrong-number-of-args-error
blame val blame #:missing-party neg-party val
args-len max-arity min-method-arity max-method-arity)) args-len max-arity min-method-arity max-method-arity))
;; these two for loops are doing O(n^2) work that could be linear ;; these two for loops are doing O(n^2) work that could be linear
;; (since the keyword lists are sorted) ;; (since the keyword lists are sorted)
(for ([req-kwd (in-list req-kwd)]) (for ([req-kwd (in-list req-kwd)])
(unless (memq req-kwd kwds) (unless (memq req-kwd kwds)
(raise-blame-error (blame-swap blame) val (raise-blame-error (blame-swap blame) #:missing-party neg-party
val
'(expected "keyword argument ~a") '(expected "keyword argument ~a")
req-kwd))) req-kwd)))
(for ([k (in-list kwds)]) (for ([k (in-list kwds)])
(unless (memq k all-kwds) (unless (memq k all-kwds)
(raise-blame-error (blame-swap blame) val (raise-blame-error (blame-swap blame) #:missing-party neg-party val
'(received: "unexpected keyword argument ~a") '(received: "unexpected keyword argument ~a")
k))) k)))
(keyword-apply kwd-lambda kwds kwd-args args)))))) (keyword-apply kwd-lambda kwds kwd-args args))))))
@ -432,16 +452,16 @@
(if (null? req-kwd) (if (null? req-kwd)
(λ args (λ args
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key blame contract-continuation-mark-key (cons blame neg-party)
(let () (let ()
(unless (valid-number-of-args? args) (unless (valid-number-of-args? args)
(define args-len (length args)) (define args-len (length args))
(raise-wrong-number-of-args-error (raise-wrong-number-of-args-error
blame val blame #:missing-party neg-party val
args-len max-arity min-method-arity max-method-arity)) args-len max-arity min-method-arity max-method-arity))
(apply basic-lambda args)))) (apply basic-lambda args))))
(λ args (λ args
(raise-blame-error (blame-swap blame) val (raise-blame-error (blame-swap blame) #:missing-party neg-party val
"expected required keyword ~a" "expected required keyword ~a"
(car req-kwd))))) (car req-kwd)))))
(if (or (not va) (pair? vr) (pair? va)) (if (or (not va) (pair? vr) (pair? va))
@ -509,15 +529,15 @@
mtd? mctc? mtd? mctc?
func)) func))
(define ((->-proj wrapper) ctc) (define ((late-neg-->-proj wrapper) ctc)
(let* ([doms-proj (map contract-projection (let* ([doms-proj (map get/build-late-neg-projection
(if (base->-dom-rest/c ctc) (if (base->-dom-rest/c ctc)
(append (base->-doms/c ctc) (list (base->-dom-rest/c ctc))) (append (base->-doms/c ctc) (list (base->-dom-rest/c ctc)))
(base->-doms/c ctc)))] (base->-doms/c ctc)))]
[doms-optional-proj (map contract-projection (base->-optional-doms/c ctc))] [doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))]
[rngs-proj (map contract-projection (base->-rngs/c ctc))] [rngs-proj (map get/build-late-neg-projection (base->-rngs/c ctc))]
[mandatory-kwds-proj (map contract-projection (base->-mandatory-kwds/c ctc))] [mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))]
[optional-kwds-proj (map contract-projection (base->-optional-kwds/c ctc))] [optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))]
[mandatory-keywords (base->-mandatory-kwds ctc)] [mandatory-keywords (base->-mandatory-kwds ctc)]
[optional-keywords (base->-optional-kwds ctc)] [optional-keywords (base->-optional-kwds ctc)]
[func (base->-func ctc)] [func (base->-func ctc)]
@ -529,11 +549,10 @@
[mtd? (base->-mtd? ctc)]) [mtd? (base->-mtd? ctc)])
(λ (orig-blame) (λ (orig-blame)
(define rng-blame (blame-add-range-context orig-blame)) (define rng-blame (blame-add-range-context orig-blame))
(define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
(define partial-doms (define partial-doms
(for/list ([dom (in-list doms-proj)] (for/list ([dom (in-list doms-proj)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(dom (blame-add-context orig-blame (dom (blame-add-context orig-blame
(if (and has-rest? (if (and has-rest?
(n . > . dom-length)) (n . > . dom-length))
"the rest argument of" "the rest argument of"
@ -563,11 +582,13 @@
(define the-args (append partial-doms partial-optional-doms (define the-args (append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds partial-mandatory-kwds partial-optional-kwds
partial-ranges)) partial-ranges))
(λ (val) (λ (val neg-party)
(if has-rest? (if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords orig-blame) (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords orig-blame)) orig-blame neg-party)
(define chap/imp-func (apply func orig-blame val the-args)) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords
orig-blame neg-party))
(define chap/imp-func (apply func orig-blame neg-party val the-args))
(if post (if post
(wrapper (wrapper
val val
@ -632,18 +653,17 @@
(define-struct (chaperone-> base->) () (define-struct (chaperone-> base->) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:late-neg-projection (late-neg-->-proj chaperone-procedure)
#:projection (->-proj chaperone-procedure) #:name ->-name
#:name ->-name #:first-order ->-first-order
#:first-order ->-first-order #:stronger ->-stronger?))
#:stronger ->-stronger?)))
(define-struct (impersonator-> base->) () (define-struct (impersonator-> base->) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection (->-proj impersonate-procedure) #:late-neg-projection (late-neg-->-proj impersonate-procedure)
#:name ->-name #:name ->-name
#:first-order ->-first-order #:first-order ->-first-order
#:stronger ->-stronger?)) #:stronger ->-stronger?))
@ -796,9 +816,9 @@
(with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)] (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
[outer-lambda [outer-lambda
#`(lambda (blame val dom-names ... kwd-names ... rng-names ...) #`(lambda (blame neg-party val dom-names ... kwd-names ... rng-names ...)
#,(create-chaperone #,(create-chaperone
#'blame #'val #f #f #'blame #'neg-party #'val #f #f
(syntax->list #'(this-params ...)) (syntax->list #'(this-params ...))
(syntax->list #'(dom-names ...)) null #f (syntax->list #'(dom-names ...)) null #f
(map list (syntax->list #'(kwds ...)) (map list (syntax->list #'(kwds ...))
@ -977,7 +997,7 @@
#''()) #''())
#,(if rng-ctc #f #t) #,(if rng-ctc #f #t)
mtd? ->m-ctc? mtd? ->m-ctc?
(λ (blame f (λ (blame neg-party f
mandatory-dom-proj ... mandatory-dom-proj ...
#,@(if rest-ctc #,@(if rest-ctc
#'(rest-proj) #'(rest-proj)
@ -987,7 +1007,7 @@
optional-dom-kwd-proj ... optional-dom-kwd-proj ...
rng-proj ...) rng-proj ...)
#,(create-chaperone #,(create-chaperone
#'blame #'f pre post #'blame #'neg-party #'f pre post
(syntax->list #'(this-parameter ...)) (syntax->list #'(this-parameter ...))
(syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(mandatory-dom-proj ...))
(syntax->list #'(optional-dom-proj ...)) (syntax->list #'(optional-dom-proj ...))
@ -1249,7 +1269,7 @@
(syntax-local-infer-name stx) (syntax-local-infer-name stx)
#`(λ args (apply f args)))))))))))))])) #`(λ args (apply f args)))))))))))))]))
(define ((->d-proj wrap-procedure) ->d-stct) (define ((late-neg-->d-proj wrap-procedure) ->d-stct)
(let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))] (let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))]
[mandatory-count (+ (length (base-->d-mandatory-dom-ctcs ->d-stct)) [mandatory-count (+ (length (base-->d-mandatory-dom-ctcs ->d-stct))
(if (base-->d-mtd? ->d-stct) 1 0))] (if (base-->d-mtd? ->d-stct) 1 0))]
@ -1266,28 +1286,32 @@
[else [else
(cons (+ mandatory-count i) (loop (+ i 1)))]))])]) (cons (+ mandatory-count i) (loop (+ i 1)))]))])])
(λ (blame) (λ (blame)
(λ (val) (define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
(if (base-->d-rest-ctc ->d-stct) (define rng-blame (blame-add-range-context blame))
(check-procedure/more val (λ (val neg-party)
(base-->d-mtd? ->d-stct) (if (base-->d-rest-ctc ->d-stct)
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length (check-procedure/more val
(base-->d-mandatory-keywords ->d-stct) (base-->d-mtd? ->d-stct)
(base-->d-optional-keywords ->d-stct) (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
blame) (base-->d-mandatory-keywords ->d-stct)
(check-procedure val (base-->d-optional-keywords ->d-stct)
(base-->d-mtd? ->d-stct) blame
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length neg-party)
(length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length (check-procedure val
(base-->d-mandatory-keywords ->d-stct) (base-->d-mtd? ->d-stct)
(base-->d-optional-keywords ->d-stct) (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
blame)) (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(wrap-procedure (base-->d-mandatory-keywords ->d-stct)
val (base-->d-optional-keywords ->d-stct)
(make-keyword-procedure blame
(λ (kwd-args kwd-arg-vals . raw-orig-args) neg-party))
(with-continuation-mark (wrap-procedure
contract-continuation-mark-key blame val
(let* ([orig-args (if (base-->d-mtd? ->d-stct) (make-keyword-procedure
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(with-continuation-mark
contract-continuation-mark-key (cons blame neg-party)
(let* ([orig-args (if (base-->d-mtd? ->d-stct)
(cdr raw-orig-args) (cdr raw-orig-args)
raw-orig-args)] raw-orig-args)]
[this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))] [this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))]
@ -1296,7 +1320,7 @@
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (base-->d-pre-cond ->d-stct) (when (base-->d-pre-cond ->d-stct)
(unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args) (unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args)
(raise-blame-error (blame-swap blame) (raise-blame-error (blame-swap blame) #:missing-party neg-party
val val
"#:pre violation~a" "#:pre violation~a"
(build-values-string ", argument" dep-pre-args)))) (build-values-string ", argument" dep-pre-args))))
@ -1316,44 +1340,44 @@
(if rng (if rng
(list (λ orig-results (list (λ orig-results
(with-continuation-mark (with-continuation-mark
contract-continuation-mark-key blame contract-continuation-mark-key (cons blame neg-party)
(let* ([range-count (length rng)] (let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)] [post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (base-->d-rest-ctc ->d-stct) post-args (base-->d-rest-ctc ->d-stct)
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (base-->d-post-cond ->d-stct) (when (base-->d-post-cond ->d-stct)
(unless (apply (base-->d-post-cond ->d-stct) dep-post-args) (unless (apply (base-->d-post-cond ->d-stct) dep-post-args)
(raise-blame-error blame (raise-blame-error blame #:missing-party neg-party
val
"#:post violation~a~a"
(build-values-string ", argument" dep-pre-args)
(build-values-string (if (null? dep-pre-args)
", result"
"\n result")
orig-results))))
(unless (= range-count (length orig-results))
(raise-blame-error blame #:missing-party neg-party
val val
"#:post violation~a~a" "expected ~a results, got ~a"
(build-values-string ", argument" dep-pre-args) range-count
(build-values-string (if (null? dep-pre-args) (length orig-results)))
", result" (apply
"\n result") values
orig-results)))) (let loop ([results orig-results]
[result-contracts rng])
(unless (= range-count (length orig-results)) (cond
(raise-blame-error blame [(null? result-contracts) '()]
val [else
"expected ~a results, got ~a" (cons
range-count (invoke-dep-ctc (car result-contracts)
(length orig-results))) (if rng-underscore? #f dep-post-args)
(apply (car results)
values rng-blame
(let loop ([results orig-results] neg-party)
[result-contracts rng]) (loop (cdr results) (cdr result-contracts)))])))))))
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results)
blame
#f)
(loop (cdr results) (cdr result-contracts)))])))))))
null)) null))
;; contracted keyword arguments ;; contracted keyword arguments
@ -1365,9 +1389,16 @@
[(or (null? building-kwd-args) (null? all-kwds)) '()] [(or (null? building-kwd-args) (null? all-kwds)) '()]
[else (if (eq? (car all-kwds) [else (if (eq? (car all-kwds)
(car building-kwd-args)) (car building-kwd-args))
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) blame #t) (cons (invoke-dep-ctc (car kwd-ctcs)
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) dep-pre-args
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))]) (car building-kwd-arg-vals)
dom-blame
neg-party)
(loop (cdr all-kwds) (cdr kwd-ctcs)
(cdr building-kwd-args)
(cdr building-kwd-arg-vals)))
(loop (cdr all-kwds) (cdr kwd-ctcs)
building-kwd-args building-kwd-arg-vals))]))])
(if (null? kwd-res) null (list kwd-res))) (if (null? kwd-res) null (list kwd-res)))
@ -1383,20 +1414,24 @@
(cond (cond
[(null? args) [(null? args)
(if (base-->d-rest-ctc ->d-stct) (if (base-->d-rest-ctc ->d-stct)
(invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() blame #t) (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '()
dom-blame neg-party)
'())] '())]
[(null? non-kwd-ctcs) [(null? non-kwd-ctcs)
(if (base-->d-rest-ctc ->d-stct) (if (base-->d-rest-ctc ->d-stct)
(invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args blame #t) (invoke-dep-ctc (base-->d-rest-ctc ->d-stct)
dep-pre-args args dom-blame neg-party)
;; ran out of arguments, but don't have a rest parameter. ;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is ;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen. ;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ happen))] (error 'shouldnt\ happen))]
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) blame #t) [else (cons (invoke-dep-ctc (car non-kwd-ctcs)
dep-pre-args (car args)
dom-blame neg-party)
(loop (cdr args) (loop (cdr args)
(cdr non-kwd-ctcs)))])))))))) (cdr non-kwd-ctcs)))]))))))))
impersonator-prop:contracted ->d-stct))))) impersonator-prop:contracted ->d-stct)))))
(define (build-values-string desc dep-pre-args) (define (build-values-string desc dep-pre-args)
(cond (cond
@ -1413,15 +1448,14 @@
(loop (cdr lst)))])))])) (loop (cdr lst)))])))]))
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst ;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
(define (invoke-dep-ctc dep-ctc dep-args val blame dom?) (define (invoke-dep-ctc dep-ctc dep-args val blame neg-party)
(let ([ctc (coerce-contract '->d (if dep-args (let ([ctc (coerce-contract '->d (if dep-args
(apply dep-ctc dep-args) (apply dep-ctc dep-args)
dep-ctc))]) dep-ctc))])
(((contract-projection ctc) (((get/build-late-neg-projection ctc)
(if dom? blame)
(blame-add-context blame "the domain of" #:swap? #t) val
(blame-add-range-context blame))) neg-party)))
val)))
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any) ;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args) (define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
@ -1529,8 +1563,8 @@
[optional-kwds (base-->d-optional-keywords ctc)]) [optional-kwds (base-->d-optional-keywords ctc)])
(λ (val) (λ (val)
(if (base-->d-rest-ctc ctc) (if (base-->d-rest-ctc ctc)
(check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f) (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f #f)
(check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f))))) (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f #f)))))
(define (->d-stronger? this that) (eq? this that)) (define (->d-stronger? this that) (eq? this that))
;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that ;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
@ -1564,7 +1598,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection (->d-proj impersonate-procedure) #:late-neg-projection (late-neg-->d-proj impersonate-procedure)
#:name ->d-name #:name ->d-name
#:first-order ->d-first-order #:first-order ->d-first-order
#:stronger ->d-stronger?)) #:stronger ->d-stronger?))
@ -1637,7 +1671,8 @@
;; check-procedure : ... (or/c #f blame) -> (or/c boolean? void?) ;; check-procedure : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched ;; if blame is #f, then just return a boolean indicating that this matched
;; (for use in arity checking) ;; (for use in arity checking)
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame) (define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords
blame neg-party)
(define passes? (define passes?
(and (procedure? val) (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
@ -1646,7 +1681,7 @@
[blame [blame
(unless passes? (unless passes?
(raise-blame-error (raise-blame-error
blame blame #:missing-party neg-party
val val
'(expected " a ~a that accepts ~a~a~a argument~a~a~a" given: "~e") '(expected " a ~a that accepts ~a~a~a argument~a~a~a" given: "~e")
(if mtd? "method" "procedure") (if mtd? "method" "procedure")
@ -1712,7 +1747,7 @@
;; check-procedure/more : ... (or/c #f blame) -> (or/c boolean? void?) ;; check-procedure/more : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched ;; if blame is #f, then just return a boolean indicating that this matched
;; (for use in arity checking) ;; (for use in arity checking)
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame) (define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame neg-party)
(define passes? (define passes?
(and (procedure? val) (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))

57
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -74,9 +74,9 @@
[rng [rng
(let ([rng-checkers (let ([rng-checkers
(list #`(case-lambda (list #`(case-lambda
[(rng-id ...) (values/drop (rng-proj-x rng-id) ...)] [(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)]
[args [args
(bad-number-of-results blame f (bad-number-of-results blame #:missing-party neg-party f
#,(length (syntax->list #'(rng-id ...))) #,(length (syntax->list #'(rng-id ...)))
args args
#,n)]))] #,n)]))]
@ -85,19 +85,20 @@
(check-tail-contract #'(rng-proj-x ...) rng-checkers (check-tail-contract #'(rng-proj-x ...) rng-checkers
(λ (rng-checks) (λ (rng-checks)
#`(apply values #,@rng-checks this-parameter ... #`(apply values #,@rng-checks this-parameter ...
(dom-proj-x dom-formals) ... (dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal)))) (rst-proj-x rst-formal neg-party))))
(check-tail-contract #'(rng-proj-x ...) rng-checkers (check-tail-contract
(λ (rng-checks) #'(rng-proj-x ...) rng-checkers
#`(values/drop #,@rng-checks this-parameter ... (λ (rng-checks)
(dom-proj-x dom-formals) ...)))))] #`(values/drop #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ...)))))]
[rst [rst
#`(apply values this-parameter ... #`(apply values this-parameter ...
(dom-proj-x dom-formals) ... (dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal))] (rst-proj-x rst-formal neg-party))]
[else [else
#`(values/drop this-parameter ... #`(values/drop this-parameter ...
(dom-proj-x dom-formals) ...)])))))) (dom-proj-x dom-formals neg-party) ...)]))))))
(define-syntax (case-> stx) (define-syntax (case-> stx)
(syntax-case stx () (syntax-case stx ()
@ -130,7 +131,7 @@
ctc ctc
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f) (λ (f neg-party)
(put-it-together (put-it-together
#,(let ([case-lam (syntax/loc stx #,(let ([case-lam (syntax/loc stx
(case-lambda [formals body] ...))]) (case-lambda [formals body] ...))])
@ -138,14 +139,14 @@
#`(let ([#,name #,case-lam]) #,name) #`(let ([#,name #,case-lam]) #,name)
case-lam)) case-lam))
(list (list rng-proj-x ...) ...) (list (list rng-proj-x ...) ...)
f blame wrapper ctc f blame neg-party wrapper ctc
chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))])) chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))]))
(define (put-it-together the-case-lam range-projections f blame wrapper ctc chk mtd?) (define (put-it-together the-case-lam range-projections f blame neg-party wrapper ctc chk mtd?)
(chk f mtd?) (chk f mtd?)
(define checker (define checker
(make-keyword-procedure (make-keyword-procedure
(raise-no-keywords-error f blame) (raise-no-keywords-error f blame neg-party)
(λ args (λ args
(with-continuation-mark contract-continuation-mark-key blame (with-continuation-mark contract-continuation-mark-key blame
(apply the-case-lam args))))) (apply the-case-lam args)))))
@ -155,17 +156,18 @@
f f
checker checker
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame impersonator-prop:blame (blame-add-missing-party blame neg-party)
impersonator-prop:application-mark (cons contract-key same-rngs)) impersonator-prop:application-mark (cons contract-key same-rngs))
(wrapper (wrapper
f f
checker checker
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame))) impersonator-prop:blame (blame-add-missing-party blame neg-party))))
(define (raise-no-keywords-error f blame) (define (raise-no-keywords-error f blame neg-party)
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(raise-blame-error blame f "expected no keywords, got keyword ~a" (car kwds)))) (raise-blame-error blame f #:missing-party neg-party
"expected no keywords, got keyword ~a" (car kwds))))
;; dom-ctcs : (listof (listof contract)) ;; dom-ctcs : (listof (listof contract))
;; rst-ctcs : (listof contract) ;; rst-ctcs : (listof contract)
@ -180,8 +182,7 @@
(define (case->-proj wrapper) (define (case->-proj wrapper)
(λ (ctc) (λ (ctc)
(define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc)) (define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc))
(define rng-ctcs (map contract-projection (define rng-late-neg-ctcs (map contract-late-neg-projection (get-case->-rng-ctcs ctc)))
(get-case->-rng-ctcs ctc)))
(define rst-ctcs (base-case->-rst-ctcs ctc)) (define rst-ctcs (base-case->-rst-ctcs ctc))
(define specs (base-case->-specs ctc)) (define specs (base-case->-specs ctc))
(λ (blame) (λ (blame)
@ -210,7 +211,7 @@
(apply p args)))]) (apply p args)))])
(set! memo (cons (cons f new) memo)) (set! memo (cons (cons f new) memo))
new)))) new))))
rng-ctcs))) rng-late-neg-ctcs)))
(define (chk val mtd?) (define (chk val mtd?)
(cond (cond
[(null? specs) [(null? specs)
@ -220,8 +221,8 @@
(for-each (for-each
(λ (dom-length has-rest?) (λ (dom-length has-rest?)
(if has-rest? (if has-rest?
(check-procedure/more val mtd? dom-length '() '() blame) (check-procedure/more val mtd? dom-length '() '() blame #f)
(check-procedure val mtd? dom-length 0 '() '() blame))) (check-procedure val mtd? dom-length 0 '() '() blame #f)))
specs rst-ctcs)])) specs rst-ctcs)]))
(apply (base-case->-wrapper ctc) (apply (base-case->-wrapper ctc)
chk chk
@ -260,7 +261,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:projection (case->-proj chaperone-procedure) #:late-neg-projection (case->-proj chaperone-procedure)
#:name case->-name #:name case->-name
#:first-order case->-first-order #:first-order case->-first-order
#:stronger case->-stronger?)) #:stronger case->-stronger?))
@ -269,7 +270,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection (case->-proj impersonate-procedure) #:late-neg-projection (case->-proj impersonate-procedure)
#:name case->-name #:name case->-name
#:first-order case->-first-order #:first-order case->-first-order
#:stronger case->-stronger?)) #:stronger case->-stronger?))
@ -290,11 +291,11 @@
[rst (in-list (base-case->-rst-ctcs ctc))] [rst (in-list (base-case->-rst-ctcs ctc))]
[i (in-naturals)]) [i (in-naturals)])
(define dom+case-nums (define dom+case-nums
(map (λ (dom) (cons i (contract-projection dom))) doms)) (map (λ (dom) (cons i (contract-late-neg-projection dom))) doms))
(append acc (append acc
(if rst (if rst
(append dom+case-nums (append dom+case-nums
(list (cons i (contract-projection rst)))) (list (cons i (contract-late-neg-projection rst))))
dom+case-nums)))) dom+case-nums))))
(define (get-case->-rng-ctcs ctc) (define (get-case->-rng-ctcs ctc)

189
racket/collects/racket/contract/private/misc.rkt
View File

@ -57,6 +57,7 @@
contract-late-neg-projection ;; might return #f (if none) contract-late-neg-projection ;; might return #f (if none)
get/build-val-first-projection ;; builds one if necc., using contract-projection get/build-val-first-projection ;; builds one if necc., using contract-projection
get/build-late-neg-projection get/build-late-neg-projection
warn-about-val-first?
contract-name contract-name
n->th n->th
@ -276,14 +277,13 @@
(define-struct (chaperone-and/c base-and/c) () (define-struct (chaperone-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:projection and-proj
#:projection and-proj #:late-neg-projection late-neg-and-proj
#:late-neg-projection late-neg-and-proj #:name and-name
#:name and-name #:first-order and-first-order
#:first-order and-first-order #:stronger and-stronger?
#:stronger and-stronger? #:generate and/c-generate?))
#:generate and/c-generate?)))
(define-struct (impersonator-and/c base-and/c) () (define-struct (impersonator-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
@ -449,20 +449,21 @@
(build-flat-contract-property (build-flat-contract-property
#:name (λ (c) `(,name ,(</>-ctc-x c))) #:name (λ (c) `(,name ,(</>-ctc-x c)))
#:first-order (λ (ctc) (define x (</>-ctc-x ctc)) (λ (y) (and (real? y) (</> y x)))) #:first-order (λ (ctc) (define x (</>-ctc-x ctc)) (λ (y) (and (real? y) (</> y x))))
#:projection (λ (ctc) #:late-neg-projection
(define x (</>-ctc-x ctc)) (λ (ctc)
(λ (blame) (define x (</>-ctc-x ctc))
(λ (val) (λ (blame)
(if (and (real? val) (</> val x)) (λ (val neg-party)
val (if (and (real? val) (</> val x))
(raise-blame-error val
blame val (raise-blame-error
'(expected: blame val #:missing-party neg-party
"a number strictly ~a than ~v" '(expected:
given: "~v") "a number strictly ~a than ~v"
less/greater given: "~v")
x less/greater
val))))) x
val)))))
#:generate #:generate
(λ (ctc) (λ (ctc)
(define x (</>-ctc-x ctc)) (define x (</>-ctc-x ctc))
@ -968,15 +969,14 @@
(define-struct (chaperone-cons/c the-cons/c) () (define-struct (chaperone-cons/c the-cons/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d)))
#: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)))
#:projection (cons/c-ho-check (λ (v a d) (cons a d))) #:name cons/c-name
#:name cons/c-name #:first-order cons/c-first-order
#:first-order cons/c-first-order #:stronger cons/c-stronger?
#:stronger cons/c-stronger? #:generate cons/c-generate
#:generate cons/c-generate #:list-contract? cons/c-list-contract?))
#:list-contract? cons/c-list-contract?)))
(define-struct (impersonator-cons/c the-cons/c) () (define-struct (impersonator-cons/c the-cons/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
@ -1355,16 +1355,15 @@
(struct chaperone-list/c generic-list/c () (struct chaperone-list/c generic-list/c ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:name list/c-name-proc
#:name list/c-name-proc #:first-order list/c-first-order
#:first-order list/c-first-order #:generate list/c-generate
#:generate list/c-generate #:exercise list/c-exercise
#:exercise list/c-exercise #:stronger list/c-stronger
#:stronger list/c-stronger #:projection list/c-chaperone/other-projection
#:projection list/c-chaperone/other-projection #:late-neg-projection list/c-chaperone/other-late-neg-projection
#:late-neg-projection list/c-chaperone/other-late-neg-projection #:list-contract? (λ (c) #t)))
#:list-contract? (λ (c) #t))))
(struct higher-order-list/c generic-list/c () (struct higher-order-list/c generic-list/c ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -1913,10 +1912,10 @@
((proj blame) val)))) ((proj blame) val))))
(define (generator evt) (define (generator evt)
(values evt (checker evt))) (values evt (checker evt)))
(λ (val) (λ (val neg-party)
(unless (contract-first-order-passes? evt-ctc val) (unless (contract-first-order-passes? evt-ctc val)
(raise-blame-error (raise-blame-error
blame val blame val #:missing-party neg-party
'(expected: "~s" given: "~e") '(expected: "~s" given: "~e")
(contract-name evt-ctc) (contract-name evt-ctc)
val)) val))
@ -1944,7 +1943,7 @@
(define-struct chaperone-evt/c (ctcs) (define-struct chaperone-evt/c (ctcs)
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:projection evt/c-proj #:late-neg-projection evt/c-proj
#:first-order evt/c-first-order #:first-order evt/c-first-order
#:stronger evt/c-stronger? #:stronger evt/c-stronger?
#:name evt/c-name)) #:name evt/c-name))
@ -2063,33 +2062,95 @@
(define (contract? x) (and (coerce-contract/f x) #t)) (define (contract? x) (and (coerce-contract/f x) #t))
(define (contract-projection ctc) (define (contract-projection ctc)
(contract-struct-projection (get/build-projection
(coerce-contract 'contract-projection ctc))) (coerce-contract 'contract-projection ctc)))
(define (contract-val-first-projection ctc) (define (contract-val-first-projection ctc)
(contract-struct-val-first-projection (get/build-val-first-projection
(coerce-contract 'contract-projection ctc))) (coerce-contract 'contract-projection ctc)))
(define (contract-late-neg-projection ctc) (define (contract-late-neg-projection ctc)
(contract-struct-late-neg-projection (get/build-late-neg-projection
(coerce-contract 'contract-projection ctc))) (coerce-contract 'contract-projection ctc)))
(define (get/build-val-first-projection ctc) (define-logger racket/contract)
(or (contract-struct-val-first-projection ctc)
(let ([p (contract-projection ctc)])
(λ (blme)
(procedure-rename
(λ (val)
(λ (neg-party)
((p (blame-add-missing-party blme neg-party)) val)))
(string->symbol (format "val-first: ~s" (contract-name ctc))))))))
(define (get/build-late-neg-projection ctc) (define (get/build-late-neg-projection ctc)
(or (contract-struct-late-neg-projection ctc) (cond
(let ([p (contract-projection ctc)]) [(contract-struct-late-neg-projection ctc) => values]
(λ (blme) [else
(procedure-rename (log-racket/contract-warning "no late-neg-projection for ~s" ctc)
(λ (val neg-party) (cond
((p (blame-add-missing-party blme neg-party)) val)) [(contract-struct-projection ctc)
(string->symbol (format "late-neg: ~s" (contract-name ctc)))))))) =>
(λ (projection)
(projection->late-neg-projection projection))]
[(contract-struct-val-first-projection ctc)
=>
(λ (val-first-projection)
(val-first-projection->late-neg-projection val-first-projection))]
[else
(first-order->late-neg-projection (contract-struct-first-order ctc)
(contract-struct-name ctc))])]))
(define (projection->late-neg-projection proj)
(λ (b)
(λ (x neg-party)
((proj (blame-add-missing-party b neg-party)) x))))
(define (val-first-projection->late-neg-projection vf-proj)
(λ (b)
(define vf-val-accepter (vf-proj b))
(λ (x neg-party)
((vf-val-accepter x) neg-party))))
(define (first-order->late-neg-projection p? name)
(λ (b)
(λ (x neg-party)
(if (p? x)
x
(raise-blame-error
b x #:missing-party neg-party
'(expected: "~a" given: "~e")
name
x)))))
(define warn-about-val-first? (make-parameter #t))
(define (get/build-val-first-projection ctc)
(cond
[(contract-struct-val-first-projection ctc) => values]
[else
(when (warn-about-val-first?)
(log-racket/contract-warning
"building val-first-projection of contract ~s for~a"
ctc
(build-context)))
(late-neg-projection->val-first-projection
(get/build-late-neg-projection ctc))]))
(define (late-neg-projection->val-first-projection lnp)
(λ (b)
(define val+neg-party-accepter (lnp b))
(λ (x)
(λ (neg-party)
(val+neg-party-accepter x neg-party)))))
(define (get/build-projection ctc)
(cond
[(contract-struct-projection ctc) => values]
[else
(log-racket/contract-warning
"building projection of contract ~s for~a"
ctc
(build-context))
(late-neg-projection->projection
(get/build-late-neg-projection ctc))]))
(define (late-neg-projection->projection lnp)
(λ (b)
(define val+np-acceptor (lnp b))
(λ (x)
(val+np-acceptor x #f))))
(define (build-context)
(apply
string-append
(for/list ([i (in-list (continuation-mark-set->context
(current-continuation-marks)))])
(format "\n ~s" i))))
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-named-contract name pre-contract [generate #f]) (define (flat-named-contract name pre-contract [generate #f])

4
racket/collects/racket/contract/private/opters.rkt
View File

@ -662,7 +662,7 @@
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars))) (dom-len (length dom-vars)))
(syntax (begin (syntax (begin
(check-procedure val #f dom-len 0 '() '() #|keywords|# blame) (check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f)
(chaperone-procedure (chaperone-procedure
val val
(case-lambda (case-lambda
@ -743,7 +743,7 @@
(define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t)) (define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t))
(define (handle-non-exact-procedure val dom-len blame exact-proc) (define (handle-non-exact-procedure val dom-len blame exact-proc)
(check-procedure val #f dom-len 0 '() '() blame) (check-procedure val #f dom-len 0 '() '() blame #f)
(chaperone-procedure (chaperone-procedure
val val
(make-keyword-procedure (make-keyword-procedure

67
racket/collects/racket/contract/private/orc.rkt
View File

@ -217,18 +217,17 @@
(define-struct (chaperone-single-or/c single-or/c) () (define-struct (chaperone-single-or/c single-or/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:projection single-or/c-projection
#:projection single-or/c-projection #:late-neg-projection single-or/c-late-neg-projection
#:late-neg-projection single-or/c-late-neg-projection #:name single-or/c-name
#:name single-or/c-name #:first-order single-or/c-first-order
#:first-order single-or/c-first-order #:stronger single-or/c-stronger?
#:stronger single-or/c-stronger? #:generate (λ (ctc) (or/c-generate ctc
#:generate (λ (ctc) (or/c-generate ctc (cons (single-or/c-ho-ctc ctc)
(cons (single-or/c-ho-ctc ctc) (single-or/c-flat-ctcs ctc))))
(single-or/c-flat-ctcs ctc)))) #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))) #:list-contract? single-or/c-list-contract?))
#:list-contract? single-or/c-list-contract?)))
(define-struct (impersonator-single-or/c single-or/c) () (define-struct (impersonator-single-or/c single-or/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -376,18 +375,17 @@
(define-struct (chaperone-multi-or/c multi-or/c) () (define-struct (chaperone-multi-or/c multi-or/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:projection multi-or/c-proj
#:projection multi-or/c-proj #:late-neg-projection multi-or/c-late-neg-proj
#:late-neg-projection multi-or/c-late-neg-proj #:name multi-or/c-name
#:name multi-or/c-name #:first-order multi-or/c-first-order
#:first-order multi-or/c-first-order #:stronger multi-or/c-stronger?
#:stronger multi-or/c-stronger? #:generate (λ (ctc) (or/c-generate ctc
#:generate (λ (ctc) (or/c-generate ctc (append (multi-or/c-ho-ctcs ctc)
(append (multi-or/c-ho-ctcs ctc) (multi-or/c-flat-ctcs ctc))))
(multi-or/c-flat-ctcs ctc)))) #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))) #:list-contract? mult-or/c-list-contract?))
#:list-contract? mult-or/c-list-contract?)))
(define-struct (impersonator-multi-or/c multi-or/c) () (define-struct (impersonator-multi-or/c multi-or/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -539,16 +537,15 @@
(define-struct (chaperone-first-or/c base-first-or/c) () (define-struct (chaperone-first-or/c base-first-or/c) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:projection first-or/c-proj
#:projection first-or/c-proj #:late-neg-projection first-or/c-late-neg-proj
#:late-neg-projection first-or/c-late-neg-proj #:name first-or/c-name
#:name first-or/c-name #:first-order first-or/c-first-order
#:first-order first-or/c-first-order #:stronger multi-or/c-stronger?
#:stronger multi-or/c-stronger? #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
#:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) #:list-contract? first-or/c-list-contract?))
#:list-contract? first-or/c-list-contract?)))
(define-struct (impersonator-first-or/c base-first-or/c) () (define-struct (impersonator-first-or/c base-first-or/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
@ -596,7 +593,7 @@
(λ (ctc) (flat-rec-contract-name ctc)) (λ (ctc) (flat-rec-contract-name ctc))
#:stronger #:stronger
(let ([recur? (make-parameter #t)]) (let ([recur? (make-parameter #t)])
(λ (this that) (λ (this that)
(cond (cond
[(equal? this that) #t] [(equal? this that) #t]
[(recur?) [(recur?)

144
racket/collects/racket/contract/private/prop.rkt
View File

@ -35,8 +35,6 @@
make-chaperone-contract make-chaperone-contract
make-flat-contract make-flat-contract
skip-projection-wrapper?
prop:opt-chaperone-contract prop:opt-chaperone-contract
prop:opt-chaperone-contract? prop:opt-chaperone-contract?
prop:opt-chaperone-contract-get-test prop:opt-chaperone-contract-get-test
@ -97,10 +95,9 @@
first-order)) first-order))
(define (contract-struct-projection c) (define (contract-struct-projection c)
(let* ([prop (contract-struct-property c)] (define prop (contract-struct-property c))
[get-projection (contract-property-projection prop)] (define get-projection (contract-property-projection prop))
[projection (get-projection c)]) (and get-projection (get-projection c)))
projection))
(define (contract-struct-val-first-projection c) (define (contract-struct-val-first-projection c)
(define prop (contract-struct-property c)) (define prop (contract-struct-property c))
@ -111,7 +108,7 @@
(define (contract-struct-late-neg-projection c) (define (contract-struct-late-neg-projection c)
(define prop (contract-struct-property c)) (define prop (contract-struct-property c))
(define get-projection (contract-property-late-neg-projection prop)) (define get-projection (contract-property-late-neg-projection prop))
(and get-projection (and get-projection
(get-projection c))) (get-projection c)))
(define trail (make-parameter #f)) (define trail (make-parameter #f))
@ -256,9 +253,7 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define skip-projection-wrapper? (make-parameter #f)) (define ((build-property mk default-name proc-name first-order?)
(define ((build-property mk default-name projection-wrapper)
#:name [get-name #f] #:name [get-name #f]
#:first-order [get-first-order #f] #:first-order [get-first-order #f]
#:projection [get-projection #f] #:projection [get-projection #f]
@ -268,76 +263,41 @@
#:generate [generate (λ (ctc) (λ (fuel) #f))] #:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:list-contract? [list-contract? (λ (c) #f)]) #:list-contract? [list-contract? (λ (c) #f)])
(unless (or get-first-order
;; this code is here to help me find the combinators that get-projection
;; are still using only #:projection and not #:late-neg-projection get-val-first-projection
#; get-late-neg-projection)
(when (and get-projection (error
(not get-late-neg-projection)) proc-name
(printf "missing late-neg-projection ~s\n" (string-append
get-projection)) "expected either the #:get-projection, #:val-first-project, or #:late-neg-projection"
" to not be #f, but all three were #f")))
(let* ([get-name (or get-name (lambda (c) default-name))]
[get-first-order (or get-first-order get-any?)] (mk (or get-name (λ (c) default-name))
[get-val-first-projection (or get-first-order get-any?)
(or get-val-first-projection get-projection
(and (not get-projection) (or stronger weakest)
(get-val-first-first-order-projection get-name get-first-order)))] generate exercise
[get-late-neg-projection get-val-first-projection
(or get-late-neg-projection (cond
(and (not get-projection) [first-order?
(get-late-neg-first-order-projection get-name get-first-order)))] (or get-late-neg-projection
[get-projection (λ (c)
(cond (late-neg-first-order-projection (get-name c) (get-first-order c))))]
[get-projection [else get-late-neg-projection])
(blame-context-projection-wrapper list-contract?))
(if (skip-projection-wrapper?)
get-projection
(projection-wrapper get-projection)))]
[else (val-first-projection->projection get-val-first-projection
get-name
get-first-order)])]
[stronger (or stronger weakest)])
(mk get-name get-first-order
get-projection stronger
generate exercise
get-val-first-projection
get-late-neg-projection
list-contract?)))
(define build-contract-property (define build-contract-property
(procedure-rename (procedure-rename
(build-property make-contract-property 'anonymous-contract values) (build-property make-contract-property 'anonymous-contract 'build-contract-property #f)
'build-contract-property)) 'build-contract-property))
;; Here we'll force the projection to always return the original value,
;; instead of assuming that the provided projection does so appropriately.
(define (flat-projection-wrapper f)
(λ (c)
(let ([proj (f c)])
(λ (b)
(let ([p (proj b)])
(λ (v) (p v) v))))))
(define build-flat-contract-property (define build-flat-contract-property
(procedure-rename (procedure-rename
(build-property (compose make-flat-contract-property make-contract-property) (build-property (compose make-flat-contract-property make-contract-property)
'anonymous-flat-contract 'anonymous-flat-contract 'build-flat-contract-property #t)
flat-projection-wrapper)
'build-flat-contract-property)) 'build-flat-contract-property))
(define (chaperone-projection-wrapper f)
(λ (c)
(let ([proj (f c)])
(λ (b)
(let ([p (proj b)])
(λ (v)
(let ([v* (p v)])
(unless (chaperone-of? v* v)
(error 'prop:chaperone-contract (format "expected a chaperone of ~v, got ~v" v v*)))
v*)))))))
(define (blame-context-projection-wrapper proj) (define (blame-context-projection-wrapper proj)
(λ (ctc) (λ (ctc)
(define c-proj (proj ctc)) (define c-proj (proj ctc))
@ -347,8 +307,7 @@
(define build-chaperone-contract-property (define build-chaperone-contract-property
(procedure-rename (procedure-rename
(build-property (compose make-chaperone-contract-property make-contract-property) (build-property (compose make-chaperone-contract-property make-contract-property)
'anonymous-chaperone-contract 'anonymous-chaperone-contract 'build-chaperone-contract-property #f)
chaperone-projection-wrapper)
'build-chaperone-contract-property)) 'build-chaperone-contract-property))
(define (get-any? c) any?) (define (get-any? c) any?)
@ -460,41 +419,12 @@
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:list-contract? [list-contract? (λ (ctc) #f)]) #:list-contract? [list-contract? (λ (ctc) #f)])
(let* ([name (or name default-name)] (mk (or name default-name)
[first-order (or first-order any?)] (or first-order any?)
[projection (or projection (first-order-projection name first-order))] projection val-first-projection late-neg-projection
[val-first-projection (or val-first-projection (or stronger as-strong?)
(and (not projection) generate exercise
(val-first-first-order-projection name first-order)))] list-contract?))
[late-neg-projection (or late-neg-projection
(and (not projection)
(late-neg-first-order-projection name first-order)))]
[stronger (or stronger as-strong?)])
(mk name first-order
projection val-first-projection late-neg-projection
stronger
generate exercise
list-contract?)))
(define ((get-val-first-first-order-projection get-name get-first-order) c)
(val-first-first-order-projection (get-name c) (get-first-order c)))
(define ((get-late-neg-first-order-projection get-name get-first-order) c)
(late-neg-first-order-projection (get-name c) (get-first-order c)))
(define (val-first-first-order-projection name p?)
(λ (b)
(λ (v)
(λ (neg-party)
(if (p? v)
v
(raise-blame-error
b #:missing-party neg-party
v
'(expected: "~s" given: "~e")
name
v))))))
(define (late-neg-first-order-projection name p?) (define (late-neg-first-order-projection name p?)
(λ (b) (λ (b)

37
racket/collects/racket/contract/private/provide.rkt
View File

@ -384,36 +384,25 @@
;; ... -> (or/c #f (-> blame val)) ;; ... -> (or/c #f (-> blame val))
(define (do-partial-app ctc val name pos-module-source source) (define (do-partial-app ctc val name pos-module-source source)
(define p (contract-struct-val-first-projection ctc)) (define p (parameterize ([warn-about-val-first? #f])
;; when we're building the val-first projection
;; here we might be needing the plus1 arity
;; function (which will be on the val first's result)
;; so this is a legtimate use. don't warn.
(get/build-val-first-projection ctc)))
(define blme (make-blame (build-source-location source) (define blme (make-blame (build-source-location source)
name name
(λ () (contract-name ctc)) (λ () (contract-name ctc))
pos-module-source pos-module-source
#f #t)) #f #t))
(define neg-accepter ((p blme) val))
(cond ;; we don't have the negative blame here, but we
[p ;; expect only positive failures from this; do the
(define neg-accepter ((p blme) val)) ;; check and then toss the results.
(neg-accepter 'incomplete-blame-from-provide.rkt)
;; we don't have the negative blame here, but we
;; expect only positive failures from this; do the neg-accepter)
;; check and then toss the results.
(neg-accepter 'incomplete-blame-from-provide.rkt)
neg-accepter]
[else
(define proj (contract-struct-projection ctc))
;; we don't have the negative blame here, but we
;; expect only positive failures from this; do the
;; check and then toss the results.
((proj blme) val)
(procedure-rename
(λ (neg-party)
(define complete-blame (blame-add-missing-party blme neg-party))
((proj complete-blame) val))
(string->symbol (format "provide.rkt:neg-party-fn:~s" (contract-name ctc))))]))
(define-for-syntax (true-provide/contract provide-stx just-check-errors? who) (define-for-syntax (true-provide/contract provide-stx just-check-errors? who)
(syntax-case provide-stx () (syntax-case provide-stx ()

45
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -678,36 +678,33 @@
(define-struct (struct/dc base-struct/dc) () (define-struct (struct/dc base-struct/dc) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property
(build-chaperone-contract-property #:name struct/dc-name
#:name struct/dc-name #:first-order struct/dc-first-order
#:first-order struct/dc-first-order #:projection struct/dc-proj
#:projection struct/dc-proj #:stronger struct/dc-stronger?
#:stronger struct/dc-stronger? #:generate struct/dc-generate
#:generate struct/dc-generate #:exercise struct/dc-exercise))
#:exercise struct/dc-exercise)))
(define-struct (flat-struct/dc base-struct/dc) () (define-struct (flat-struct/dc base-struct/dc) ()
#:property prop:flat-contract #:property prop:flat-contract
(parameterize ([skip-projection-wrapper? #t]) (build-flat-contract-property
(build-flat-contract-property #:name struct/dc-name
#:name struct/dc-name #:first-order struct/dc-flat-first-order
#:first-order struct/dc-flat-first-order #:projection struct/dc-proj
#:projection struct/dc-proj #:stronger struct/dc-stronger?
#:stronger struct/dc-stronger? #:generate struct/dc-generate
#:generate struct/dc-generate #:exercise struct/dc-exercise))
#:exercise struct/dc-exercise)))
(define-struct (impersonator-struct/dc base-struct/dc) () (define-struct (impersonator-struct/dc base-struct/dc) ()
#:property prop:contract #:property prop:contract
(parameterize ([skip-projection-wrapper? #t]) (build-contract-property
(build-contract-property #:name struct/dc-name
#:name struct/dc-name #:first-order struct/dc-first-order
#:first-order struct/dc-first-order #:projection struct/dc-proj
#:projection struct/dc-proj #:stronger struct/dc-stronger?
#:stronger struct/dc-stronger? #:generate struct/dc-generate
#:generate struct/dc-generate #:exercise struct/dc-exercise))
#:exercise struct/dc-exercise)))
(define (build-struct/dc subcontracts constructor pred struct-name here name-info struct/c?) (define (build-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)
(for ([subcontract (in-list subcontracts)]) (for ([subcontract (in-list subcontracts)])