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
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
@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,
@ -2106,6 +2109,30 @@ contracts. The error messages assume that the function named by
@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}
@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
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
@racket[build-contract-property], and are applied to instances of the
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)
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
'build-chaperone-contract-property1
'(let ()
@ -156,6 +202,88 @@
(((contract-projection (val-first-none))
(make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
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
'make-flat-contract-bad-6
'(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
(require "private/prop.rkt"
(prefix-in : "private/prop.rkt")
"private/guts.rkt"
"private/blame.rkt")
@ -12,7 +13,11 @@
contract-struct-stronger?
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")
check-flat-contract
@ -21,4 +26,177 @@
has-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-kwds ctc)
(->i-opt-kwds ctc)
blame)
blame #f)
(check-procedure val mtd?
(->i-mandatory-args ctc) (->i-opt-args ctc)
(->i-mandatory-kwds ctc) (->i-opt-kwds ctc)
blame)))
blame #f)))
ctc
blame swapped-blame ;; used by the #:pre and #:post checking
(append blames
@ -313,8 +313,8 @@
[opt-kwds (->i-opt-kwds ctc)])
(λ (val)
(if has-rest
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f)
(check-procedure val mtd? mand-args opt-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 #f)))))
#:exercise exercise->i
#: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 ([basic-lambda-name basic-lambda])
(arrow:arity-checking-wrapper val
(blame-add-missing-party blame neg-party)
blame neg-party
basic-lambda-name
void
#,min-method-arity
@ -321,7 +321,7 @@
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val
(blame-add-missing-party blame neg-party)
blame neg-party
void
kwd-lambda-name
#,min-method-arity
@ -335,7 +335,7 @@
(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val
(blame-add-missing-party blame neg-party)
blame neg-party
basic-lambda-name
kwd-lambda-name
#,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))]
[kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))])
(cons kwd kwd-proj))))
(define complete-blame (blame-add-missing-party blame neg-party))
(define interposition-proc
(make-keyword-procedure
@ -936,7 +935,8 @@
(loop (cdr args) (cdr projs)))])))
(define (result-checker . 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
values
(for/list ([res (in-list results)]
@ -952,7 +952,7 @@
(cons result-checker 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
min-arity max-arity
min-arity max-arity
@ -1176,44 +1176,43 @@
(base->-plus-one-arity-function ->stct)
(base->-chaperone-constructor ->stct)
#t)))
(parameterize ([skip-projection-wrapper? #t])
(build-X-property
#:name base->-name
#:first-order ->-first-order
#:projection
(λ (this)
(define cthis (val-first-proj this))
(λ (blame)
(define cblame (cthis blame))
(λ (val)
((cblame val) #f))))
#:stronger
(λ (this that)
(and (base->? that)
(= (length (base->-doms that))
(length (base->-doms this)))
(= (base->-min-arity this) (base->-min-arity that))
(andmap contract-stronger? (base->-doms that) (base->-doms this))
(= (length (base->-kwd-infos this))
(length (base->-kwd-infos that)))
(for/and ([this-kwd-info (base->-kwd-infos this)]
[that-kwd-info (base->-kwd-infos that)])
(and (equal? (kwd-info-kwd this-kwd-info)
(kwd-info-kwd that-kwd-info))
(contract-stronger? (kwd-info-ctc that-kwd-info)
(kwd-info-ctc this-kwd-info))))
(if (base->-rngs this)
(and (base->-rngs that)
(andmap contract-stronger? (base->-rngs this) (base->-rngs that)))
(not (base->-rngs that)))
(not (base->-pre? this))
(not (base->-pre? that))
(not (base->-post? this))
(not (base->-post? that))))
#:generate ->-generate
#:exercise ->-exercise
#:val-first-projection val-first-proj
#:late-neg-projection late-neg-proj)))
(build-X-property
#:name base->-name
#:first-order ->-first-order
#:projection
(λ (this)
(define cthis (val-first-proj this))
(λ (blame)
(define cblame (cthis blame))
(λ (val)
((cblame val) #f))))
#:stronger
(λ (this that)
(and (base->? that)
(= (length (base->-doms that))
(length (base->-doms this)))
(= (base->-min-arity this) (base->-min-arity that))
(andmap contract-stronger? (base->-doms that) (base->-doms this))
(= (length (base->-kwd-infos this))
(length (base->-kwd-infos that)))
(for/and ([this-kwd-info (base->-kwd-infos this)]
[that-kwd-info (base->-kwd-infos that)])
(and (equal? (kwd-info-kwd this-kwd-info)
(kwd-info-kwd that-kwd-info))
(contract-stronger? (kwd-info-ctc that-kwd-info)
(kwd-info-ctc this-kwd-info))))
(if (base->-rngs this)
(and (base->-rngs that)
(andmap contract-stronger? (base->-rngs this) (base->-rngs that)))
(not (base->-rngs that)))
(not (base->-pre? this))
(not (base->-pre? that))
(not (base->-post? this))
(not (base->-post? that))))
#:generate ->-generate
#:exercise ->-exercise
#:val-first-projection val-first-proj
#:late-neg-projection late-neg-proj))
(define-struct (-> base->) ()
#:property

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

@ -87,46 +87,46 @@
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(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)
(λ (orig-blame)
(define ctc (get-ctc))
(let ([rng-blame (blame-add-range-context orig-blame)])
(let* ([p-app-x (proj-x rng-blame)] ...
[res-checker (λ (res-x ...) (values/drop (p-app-x res-x) ...))])
(λ (val)
(check-is-a-procedure orig-blame val)
(let* ([p-app-x (proj-x rng-blame)] ...)
(λ (val neg-party)
(check-is-a-procedure orig-blame neg-party val)
(define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...))
(wrapper
val
(make-keyword-procedure
(λ (kwds kwd-vals . args)
(with-continuation-mark
contract-continuation-mark-key orig-blame
#,(check-tail-contract
#'(p-app-x ...)
(list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args)))))
contract-continuation-mark-key (cons orig-blame neg-party)
#,(check-tail-contract
#'(p-app-x ...)
(list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args)))))
(λ args
(with-continuation-mark
contract-continuation-mark-key orig-blame
#,(check-tail-contract
#'(p-app-x ...)
(list #'res-checker)
(λ (s) #`(apply values #,@s args))))))
contract-continuation-mark-key (cons orig-blame neg-party)
#,(check-tail-contract
#'(p-app-x ...)
(list #'res-checker)
(λ (s) #`(apply values #,@s args))))))
impersonator-prop:contracted ctc
impersonator-prop:application-mark
(cons contract-key (list p-app-x ...))))))))
(make-unconstrained-domain-> (list rngs-x ...)
projection))))]))
(define (check-is-a-procedure orig-blame val)
(define (check-is-a-procedure orig-blame neg-party val)
(unless (procedure? val)
(raise-blame-error orig-blame
(raise-blame-error orig-blame #:missing-party neg-party
val
'(expected: "a procedure" given: "~v")
val)))
(define (make-unconstrained-domain-> ctcs projection)
(define (make-unconstrained-domain-> ctcs late-neg-projection)
(define name
(apply build-compound-type-name 'unconstrained-domain->
(map contract-name ctcs)))
@ -134,11 +134,11 @@
(if (andmap chaperone-contract? ctcs)
(make-chaperone-contract
#:name name
#:projection (projection chaperone-procedure (λ () ctc))
#:late-neg-projection (late-neg-projection chaperone-procedure (λ () ctc))
#:first-order procedure?)
(make-contract
#:name name
#:projection (projection impersonate-procedure (λ () ctc))
#:late-neg-projection (late-neg-projection impersonate-procedure (λ () ctc))
#:first-order procedure?)))
ctc)
@ -201,18 +201,25 @@
(loop (cdr accepted) req-kwds (cdr opt-kwds))]
[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]
[neg-party neg-party]
[val val])
(with-syntax ([(pre ...)
(if 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)]
[(post ...)
(if post
(list #`(unless #,post
(raise-blame-error blame val "#:post condition")))
(raise-blame-error
blame #:missing-party neg-party
val "#:post condition")))
null)])
(with-syntax ([(this-param ...) this-args]
[(dom-ctc ...) doms]
@ -240,12 +247,12 @@
(if (and (pair? rngs) (null? (cdr rngs)))
(with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))]
[name (car (syntax->list #'(rng-x ...)))])
#'(proj name))
#'(values/drop (rng-ctc rng-x) ...))])
#'(proj name neg-party))
#'(values/drop (rng-ctc rng-x neg-party) ...))])
#'(case-lambda
[(rng-x ...)
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key (cons blame neg-party)
(let ()
post ...
rng-results))]
@ -267,13 +274,15 @@
[else
#'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])]
[opt+rest-uses
(for/fold ([i (if dom-rest #'(rest-ctc rest-x) #'null)])
([o (in-list (reverse (syntax->list #'([opt-dom-ctc opt-dom-x] ...))))])
(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) ...))))])
(let* ([l (syntax->list o)]
[c (car l)]
[x (cadr l)])
#`(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 ...)
(apply append
(map list
@ -282,9 +291,12 @@
[kwd-stx
(let* ([req-stxs
(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
(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-ctc ...)))]
[reqs (map cons req-keywords req-stxs)]
@ -301,16 +313,23 @@
[basic-return
(let ([inner-stx-gen
(if need-apply-values?
(λ (s) #`(apply values #,@s this-param ... (dom-ctc dom-x) ... opt+rest-uses))
(λ (s) #`(values/drop #,@s this-param ... (dom-ctc dom-x) ...)))])
(λ (s) #`(apply values #,@s this-param ...
(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?
(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
(let* ([inner-stx-gen
(if need-apply-values?
(λ (s k) #`(apply values #,@s #,@k this-param ... (dom-ctc dom-x) ... opt+rest-uses))
(λ (s k) #`(values/drop #,@s #,@k this-param ... (dom-ctc dom-x) ...)))]
(λ (s k) #`(apply values #,@s #,@k this-param ...
(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
(if (null? req-keywords)
(λ (s)
@ -335,13 +354,13 @@
;; noticeable in my measurements so far.
;; - stamourv
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key (cons blame neg-party)
(let ()
pre ... basic-return)))]
[kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key (cons blame neg-party)
(let ()
pre ... kwd-return)))])
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
@ -349,7 +368,7 @@
[(and (null? req-keywords) (null? opt-keywords))
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame
(arity-checking-wrapper val blame neg-party
basic-lambda-name
void
#,min-method-arity
@ -361,7 +380,7 @@
[(pair? req-keywords)
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame
(arity-checking-wrapper val blame neg-party
void
kwd-lambda-name
#,min-method-arity
@ -374,7 +393,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame
(arity-checking-wrapper val blame neg-party
basic-lambda-name
kwd-lambda-name
#,min-method-arity
@ -385,7 +404,7 @@
'(opt-kwd ...))))])))))))))))
;; 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
req-kwd opt-kwd)
;; should not build this unless we are in the 'else' case (and maybe not at all)
@ -404,27 +423,28 @@
(define kwd-checker
(if (and (null? req-kwd) (null? opt-kwd))
(λ (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)
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key (cons blame neg-party)
(let ()
(define args-len (length args))
(unless (valid-number-of-args? args)
(raise-wrong-number-of-args-error
blame val
blame #:missing-party neg-party val
args-len max-arity min-method-arity max-method-arity))
;; these two for loops are doing O(n^2) work that could be linear
;; (since the keyword lists are sorted)
(for ([req-kwd (in-list req-kwd)])
(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")
req-kwd)))
(for ([k (in-list 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")
k)))
(keyword-apply kwd-lambda kwds kwd-args args))))))
@ -432,16 +452,16 @@
(if (null? req-kwd)
(λ args
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key (cons blame neg-party)
(let ()
(unless (valid-number-of-args? args)
(define args-len (length args))
(raise-wrong-number-of-args-error
blame val
blame #:missing-party neg-party val
args-len max-arity min-method-arity max-method-arity))
(apply basic-lambda args))))
(λ args
(raise-blame-error (blame-swap blame) val
(raise-blame-error (blame-swap blame) #:missing-party neg-party val
"expected required keyword ~a"
(car req-kwd)))))
(if (or (not va) (pair? vr) (pair? va))
@ -509,15 +529,15 @@
mtd? mctc?
func))
(define ((->-proj wrapper) ctc)
(let* ([doms-proj (map contract-projection
(define ((late-neg-->-proj wrapper) ctc)
(let* ([doms-proj (map get/build-late-neg-projection
(if (base->-dom-rest/c ctc)
(append (base->-doms/c ctc) (list (base->-dom-rest/c ctc)))
(base->-doms/c ctc)))]
[doms-optional-proj (map contract-projection (base->-optional-doms/c ctc))]
[rngs-proj (map contract-projection (base->-rngs/c ctc))]
[mandatory-kwds-proj (map contract-projection (base->-mandatory-kwds/c ctc))]
[optional-kwds-proj (map contract-projection (base->-optional-kwds/c ctc))]
[doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))]
[rngs-proj (map get/build-late-neg-projection (base->-rngs/c ctc))]
[mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))]
[optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))]
[mandatory-keywords (base->-mandatory-kwds ctc)]
[optional-keywords (base->-optional-kwds ctc)]
[func (base->-func ctc)]
@ -529,11 +549,10 @@
[mtd? (base->-mtd? ctc)])
(λ (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
(for/list ([dom (in-list doms-proj)]
[n (in-naturals 1)])
(dom (blame-add-context orig-blame
(dom (blame-add-context orig-blame
(if (and has-rest?
(n . > . dom-length))
"the rest argument of"
@ -563,11 +582,13 @@
(define the-args (append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds
partial-ranges))
(λ (val)
(λ (val neg-party)
(if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords orig-blame)
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords orig-blame))
(define chap/imp-func (apply func orig-blame val the-args))
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords
orig-blame neg-party)
(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
(wrapper
val
@ -632,18 +653,17 @@
(define-struct (chaperone-> base->) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#:projection (->-proj chaperone-procedure)
#:name ->-name
#:first-order ->-first-order
#:stronger ->-stronger?)))
(build-chaperone-contract-property
#:late-neg-projection (late-neg-->-proj chaperone-procedure)
#:name ->-name
#:first-order ->-first-order
#:stronger ->-stronger?))
(define-struct (impersonator-> base->) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
(build-contract-property
#:projection (->-proj impersonate-procedure)
#:late-neg-projection (late-neg-->-proj impersonate-procedure)
#:name ->-name
#:first-order ->-first-order
#:stronger ->-stronger?))
@ -796,9 +816,9 @@
(with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
[outer-lambda
#`(lambda (blame val dom-names ... kwd-names ... rng-names ...)
#`(lambda (blame neg-party val dom-names ... kwd-names ... rng-names ...)
#,(create-chaperone
#'blame #'val #f #f
#'blame #'neg-party #'val #f #f
(syntax->list #'(this-params ...))
(syntax->list #'(dom-names ...)) null #f
(map list (syntax->list #'(kwds ...))
@ -977,7 +997,7 @@
#''())
#,(if rng-ctc #f #t)
mtd? ->m-ctc?
(λ (blame f
(λ (blame neg-party f
mandatory-dom-proj ...
#,@(if rest-ctc
#'(rest-proj)
@ -987,7 +1007,7 @@
optional-dom-kwd-proj ...
rng-proj ...)
#,(create-chaperone
#'blame #'f pre post
#'blame #'neg-party #'f pre post
(syntax->list #'(this-parameter ...))
(syntax->list #'(mandatory-dom-proj ...))
(syntax->list #'(optional-dom-proj ...))
@ -1249,7 +1269,7 @@
(syntax-local-infer-name stx)
#`(λ 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))]
[mandatory-count (+ (length (base-->d-mandatory-dom-ctcs ->d-stct))
(if (base-->d-mtd? ->d-stct) 1 0))]
@ -1266,28 +1286,32 @@
[else
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
(λ (blame)
(λ (val)
(if (base-->d-rest-ctc ->d-stct)
(check-procedure/more val
(base-->d-mtd? ->d-stct)
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(base-->d-mandatory-keywords ->d-stct)
(base-->d-optional-keywords ->d-stct)
blame)
(check-procedure val
(base-->d-mtd? ->d-stct)
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(base-->d-mandatory-keywords ->d-stct)
(base-->d-optional-keywords ->d-stct)
blame))
(wrap-procedure
val
(make-keyword-procedure
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(with-continuation-mark
contract-continuation-mark-key blame
(let* ([orig-args (if (base-->d-mtd? ->d-stct)
(define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
(define rng-blame (blame-add-range-context blame))
(λ (val neg-party)
(if (base-->d-rest-ctc ->d-stct)
(check-procedure/more val
(base-->d-mtd? ->d-stct)
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(base-->d-mandatory-keywords ->d-stct)
(base-->d-optional-keywords ->d-stct)
blame
neg-party)
(check-procedure val
(base-->d-mtd? ->d-stct)
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(base-->d-mandatory-keywords ->d-stct)
(base-->d-optional-keywords ->d-stct)
blame
neg-party))
(wrap-procedure
val
(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)
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)])
(when (base-->d-pre-cond ->d-stct)
(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
"#:pre violation~a"
(build-values-string ", argument" dep-pre-args))))
@ -1316,44 +1340,44 @@
(if rng
(list (λ orig-results
(with-continuation-mark
contract-continuation-mark-key blame
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (base-->d-rest-ctc ->d-stct)
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (base-->d-post-cond ->d-stct)
(unless (apply (base-->d-post-cond ->d-stct) dep-post-args)
(raise-blame-error blame
contract-continuation-mark-key (cons blame neg-party)
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (base-->d-rest-ctc ->d-stct)
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (base-->d-post-cond ->d-stct)
(unless (apply (base-->d-post-cond ->d-stct) dep-post-args)
(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
"#: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
val
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(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)))])))))))
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results)
rng-blame
neg-party)
(loop (cdr results) (cdr result-contracts)))])))))))
null))
;; contracted keyword arguments
@ -1365,9 +1389,16 @@
[(or (null? building-kwd-args) (null? all-kwds)) '()]
[else (if (eq? (car all-kwds)
(car building-kwd-args))
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) blame #t)
(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))]))])
(cons (invoke-dep-ctc (car kwd-ctcs)
dep-pre-args
(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)))
@ -1383,20 +1414,24 @@
(cond
[(null? args)
(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)
(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.
;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't 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)
(cdr non-kwd-ctcs)))]))))))))
impersonator-prop:contracted ->d-stct)))))
impersonator-prop:contracted ->d-stct)))))
(define (build-values-string desc dep-pre-args)
(cond
@ -1413,15 +1448,14 @@
(loop (cdr lst)))])))]))
;; 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
(apply dep-ctc dep-args)
dep-ctc))])
(((contract-projection ctc)
(if dom?
(blame-add-context blame "the domain of" #:swap? #t)
(blame-add-range-context blame)))
val)))
(((get/build-late-neg-projection ctc)
blame)
val
neg-party)))
;; 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)
@ -1529,8 +1563,8 @@
[optional-kwds (base-->d-optional-keywords ctc)])
(λ (val)
(if (base-->d-rest-ctc ctc)
(check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f)
(check-procedure val mtd? dom-length optionals 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 #f)))))
(define (->d-stronger? this that) (eq? this 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:contract
(build-contract-property
#:projection (->d-proj impersonate-procedure)
#:late-neg-projection (late-neg-->d-proj impersonate-procedure)
#:name ->d-name
#:first-order ->d-first-order
#:stronger ->d-stronger?))
@ -1637,7 +1671,8 @@
;; check-procedure : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched
;; (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?
(and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
@ -1646,7 +1681,7 @@
[blame
(unless passes?
(raise-blame-error
blame
blame #:missing-party neg-party
val
'(expected " a ~a that accepts ~a~a~a argument~a~a~a" given: "~e")
(if mtd? "method" "procedure")
@ -1712,7 +1747,7 @@
;; check-procedure/more : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched
;; (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?
(and (procedure? val)
(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
(let ([rng-checkers
(list #`(case-lambda
[(rng-id ...) (values/drop (rng-proj-x rng-id) ...)]
[(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)]
[args
(bad-number-of-results blame f
(bad-number-of-results blame #:missing-party neg-party f
#,(length (syntax->list #'(rng-id ...)))
args
#,n)]))]
@ -85,19 +85,20 @@
(check-tail-contract #'(rng-proj-x ...) rng-checkers
(λ (rng-checks)
#`(apply values #,@rng-checks this-parameter ...
(dom-proj-x dom-formals) ...
(rst-proj-x rst-formal))))
(check-tail-contract #'(rng-proj-x ...) rng-checkers
(λ (rng-checks)
#`(values/drop #,@rng-checks this-parameter ...
(dom-proj-x dom-formals) ...)))))]
(dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal neg-party))))
(check-tail-contract
#'(rng-proj-x ...) rng-checkers
(λ (rng-checks)
#`(values/drop #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ...)))))]
[rst
#`(apply values this-parameter ...
(dom-proj-x dom-formals) ...
(rst-proj-x rst-formal))]
(dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal neg-party))]
[else
#`(values/drop this-parameter ...
(dom-proj-x dom-formals) ...)]))))))
(dom-proj-x dom-formals neg-party) ...)]))))))
(define-syntax (case-> stx)
(syntax-case stx ()
@ -130,7 +131,7 @@
ctc
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f)
(λ (f neg-party)
(put-it-together
#,(let ([case-lam (syntax/loc stx
(case-lambda [formals body] ...))])
@ -138,14 +139,14 @@
#`(let ([#,name #,case-lam]) #,name)
case-lam))
(list (list rng-proj-x ...) ...)
f blame wrapper ctc
f blame neg-party wrapper ctc
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?)
(define checker
(make-keyword-procedure
(raise-no-keywords-error f blame)
(raise-no-keywords-error f blame neg-party)
(λ args
(with-continuation-mark contract-continuation-mark-key blame
(apply the-case-lam args)))))
@ -155,17 +156,18 @@
f
checker
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))
(wrapper
f
checker
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)
(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))
;; rst-ctcs : (listof contract)
@ -180,8 +182,7 @@
(define (case->-proj wrapper)
(λ (ctc)
(define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc))
(define rng-ctcs (map contract-projection
(get-case->-rng-ctcs ctc)))
(define rng-late-neg-ctcs (map contract-late-neg-projection (get-case->-rng-ctcs ctc)))
(define rst-ctcs (base-case->-rst-ctcs ctc))
(define specs (base-case->-specs ctc))
(λ (blame)
@ -210,7 +211,7 @@
(apply p args)))])
(set! memo (cons (cons f new) memo))
new))))
rng-ctcs)))
rng-late-neg-ctcs)))
(define (chk val mtd?)
(cond
[(null? specs)
@ -220,8 +221,8 @@
(for-each
(λ (dom-length has-rest?)
(if has-rest?
(check-procedure/more val mtd? dom-length '() '() blame)
(check-procedure val mtd? dom-length 0 '() '() blame)))
(check-procedure/more val mtd? dom-length '() '() blame #f)
(check-procedure val mtd? dom-length 0 '() '() blame #f)))
specs rst-ctcs)]))
(apply (base-case->-wrapper ctc)
chk
@ -260,7 +261,7 @@
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (case->-proj chaperone-procedure)
#:late-neg-projection (case->-proj chaperone-procedure)
#:name case->-name
#:first-order case->-first-order
#:stronger case->-stronger?))
@ -269,7 +270,7 @@
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
(build-contract-property
#:projection (case->-proj impersonate-procedure)
#:late-neg-projection (case->-proj impersonate-procedure)
#:name case->-name
#:first-order case->-first-order
#:stronger case->-stronger?))
@ -290,11 +291,11 @@
[rst (in-list (base-case->-rst-ctcs ctc))]
[i (in-naturals)])
(define dom+case-nums
(map (λ (dom) (cons i (contract-projection dom))) doms))
(map (λ (dom) (cons i (contract-late-neg-projection dom))) doms))
(append acc
(if rst
(append dom+case-nums
(list (cons i (contract-projection rst))))
(list (cons i (contract-late-neg-projection rst))))
dom+case-nums))))
(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)
get/build-val-first-projection ;; builds one if necc., using contract-projection
get/build-late-neg-projection
warn-about-val-first?
contract-name
n->th
@ -276,14 +277,13 @@
(define-struct (chaperone-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#:projection and-proj
#:late-neg-projection late-neg-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?
#:generate and/c-generate?)))
(build-chaperone-contract-property
#:projection and-proj
#:late-neg-projection late-neg-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?
#:generate and/c-generate?))
(define-struct (impersonator-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
@ -449,20 +449,21 @@
(build-flat-contract-property
#:name (λ (c) `(,name ,(</>-ctc-x c)))
#:first-order (λ (ctc) (define x (</>-ctc-x ctc)) (λ (y) (and (real? y) (</> y x))))
#:projection (λ (ctc)
(define x (</>-ctc-x ctc))
(λ (blame)
(λ (val)
(if (and (real? val) (</> val x))
val
(raise-blame-error
blame val
'(expected:
"a number strictly ~a than ~v"
given: "~v")
less/greater
x
val)))))
#:late-neg-projection
(λ (ctc)
(define x (</>-ctc-x ctc))
(λ (blame)
(λ (val neg-party)
(if (and (real? val) (</> val x))
val
(raise-blame-error
blame val #:missing-party neg-party
'(expected:
"a number strictly ~a than ~v"
given: "~v")
less/greater
x
val)))))
#:generate
(λ (ctc)
(define x (</>-ctc-x ctc))
@ -968,15 +969,14 @@
(define-struct (chaperone-cons/c the-cons/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(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?
#:generate cons/c-generate
#:list-contract? cons/c-list-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?
#:generate cons/c-generate
#:list-contract? cons/c-list-contract?))
(define-struct (impersonator-cons/c the-cons/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
@ -1355,16 +1355,15 @@
(struct chaperone-list/c generic-list/c ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#:name list/c-name-proc
#:first-order list/c-first-order
#: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))))
(build-chaperone-contract-property
#:name list/c-name-proc
#:first-order list/c-first-order
#: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)))
(struct higher-order-list/c generic-list/c ()
#:property prop:custom-write custom-write-property-proc
@ -1913,10 +1912,10 @@
((proj blame) val))))
(define (generator evt)
(values evt (checker evt)))
(λ (val)
(λ (val neg-party)
(unless (contract-first-order-passes? evt-ctc val)
(raise-blame-error
blame val
blame val #:missing-party neg-party
'(expected: "~s" given: "~e")
(contract-name evt-ctc)
val))
@ -1944,7 +1943,7 @@
(define-struct chaperone-evt/c (ctcs)
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection evt/c-proj
#:late-neg-projection evt/c-proj
#:first-order evt/c-first-order
#:stronger evt/c-stronger?
#:name evt/c-name))
@ -2063,33 +2062,95 @@
(define (contract? x) (and (coerce-contract/f x) #t))
(define (contract-projection ctc)
(contract-struct-projection
(get/build-projection
(coerce-contract 'contract-projection ctc)))
(define (contract-val-first-projection ctc)
(contract-struct-val-first-projection
(get/build-val-first-projection
(coerce-contract 'contract-projection ctc)))
(define (contract-late-neg-projection ctc)
(contract-struct-late-neg-projection
(get/build-late-neg-projection
(coerce-contract 'contract-projection ctc)))
(define (get/build-val-first-projection ctc)
(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-logger racket/contract)
(define (get/build-late-neg-projection ctc)
(or (contract-struct-late-neg-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 "late-neg: ~s" (contract-name ctc))))))))
(cond
[(contract-struct-late-neg-projection ctc) => values]
[else
(log-racket/contract-warning "no late-neg-projection for ~s" ctc)
(cond
[(contract-struct-projection 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-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)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val #f dom-len 0 '() '() #|keywords|# blame)
(check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f)
(chaperone-procedure
val
(case-lambda
@ -743,7 +743,7 @@
(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)
(check-procedure val #f dom-len 0 '() '() blame)
(check-procedure val #f dom-len 0 '() '() blame #f)
(chaperone-procedure
val
(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) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(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
#:stronger single-or/c-stronger?
#:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
#:list-contract? single-or/c-list-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
#:stronger single-or/c-stronger?
#:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
#:list-contract? single-or/c-list-contract?))
(define-struct (impersonator-single-or/c single-or/c) ()
#:property prop:custom-write custom-write-property-proc
@ -376,18 +375,17 @@
(define-struct (chaperone-multi-or/c multi-or/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(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
#:stronger multi-or/c-stronger?
#:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))
#:list-contract? mult-or/c-list-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
#:stronger multi-or/c-stronger?
#:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))
#:list-contract? mult-or/c-list-contract?))
(define-struct (impersonator-multi-or/c multi-or/c) ()
#:property prop:custom-write custom-write-property-proc
@ -539,16 +537,15 @@
(define-struct (chaperone-first-or/c base-first-or/c) ()
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(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
#:stronger multi-or/c-stronger?
#:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
#:list-contract? first-or/c-list-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
#:stronger multi-or/c-stronger?
#:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
#:list-contract? first-or/c-list-contract?))
(define-struct (impersonator-first-or/c base-first-or/c) ()
#:property prop:contract
(build-contract-property
@ -596,7 +593,7 @@
(λ (ctc) (flat-rec-contract-name ctc))
#:stronger
(let ([recur? (make-parameter #t)])
(λ (this that)
(λ (this that)
(cond
[(equal? this that) #t]
[(recur?)

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

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

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

@ -384,36 +384,25 @@
;; ... -> (or/c #f (-> blame val))
(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)
name
(λ () (contract-name ctc))
pos-module-source
#f #t))
(define neg-accepter ((p blme) val))
(cond
[p
(define neg-accepter ((p blme) val))
;; we don't have the negative blame here, but we
;; expect only positive failures from this; do the
;; 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))))]))
;; we don't have the negative blame here, but we
;; expect only positive failures from this; do the
;; check and then toss the results.
(neg-accepter 'incomplete-blame-from-provide.rkt)
neg-accepter)
(define-for-syntax (true-provide/contract provide-stx just-check-errors? who)
(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) ()
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#:name struct/dc-name
#:first-order struct/dc-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?
#:generate struct/dc-generate
#:exercise struct/dc-exercise)))
(build-chaperone-contract-property
#:name struct/dc-name
#:first-order struct/dc-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?
#:generate struct/dc-generate
#:exercise struct/dc-exercise))
(define-struct (flat-struct/dc base-struct/dc) ()
#:property prop:flat-contract
(parameterize ([skip-projection-wrapper? #t])
(build-flat-contract-property
#:name struct/dc-name
#:first-order struct/dc-flat-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?
#:generate struct/dc-generate
#:exercise struct/dc-exercise)))
(build-flat-contract-property
#:name struct/dc-name
#:first-order struct/dc-flat-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?
#:generate struct/dc-generate
#:exercise struct/dc-exercise))
(define-struct (impersonator-struct/dc base-struct/dc) ()
#:property prop:contract
(parameterize ([skip-projection-wrapper? #t])
(build-contract-property
#:name struct/dc-name
#:first-order struct/dc-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?
#:generate struct/dc-generate
#:exercise struct/dc-exercise)))
(build-contract-property
#:name struct/dc-name
#:first-order struct/dc-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?
#:generate struct/dc-generate
#:exercise struct/dc-exercise))
(define (build-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)
(for ([subcontract (in-list subcontracts)])