From 870c8d28f4a445a85fe239019d1bc206fccbaac9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 13 Nov 2011 16:55:27 -0600 Subject: [PATCH] move predicate/c from unstable/contract to racket/contract. In process, change the implementation to special case struct procedures and to use it in provide/contract. This speeds up the rendering phase of the Guide documentation by more than 2x. Thanks to Matthew for spotting the opportunity! --- collects/racket/contract/private/arrow.rkt | 23 +++++++++++++++++ collects/racket/contract/private/provide.rkt | 2 +- .../scribblings/reference/contracts.scrbl | 12 ++++++++- collects/tests/racket/contract-test.rktl | 25 ++++++++++++++++++- collects/unstable/contract.rkt | 2 -- collects/unstable/scribblings/contract.scrbl | 10 +------- 6 files changed, 60 insertions(+), 14 deletions(-) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index d99f55c7e3..47ff1af24f 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -35,6 +35,7 @@ v4 todo: case-> unconstrained-domain-> the-unsupplied-arg + (rename-out [-predicate/c predicate/c]) unsupplied-arg? making-a-method procedure-accepts-and-more? @@ -1950,3 +1951,25 @@ v4 todo: 'pos 'neg)]) (λ (x) (send o m x))))) + + +(define predicate/c-private->ctc + (let ([predicate/c (-> any/c boolean?)]) + predicate/c)) + +(struct predicate/c () + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:projection (let ([pc (contract-struct-projection predicate/c-private->ctc)]) + (λ (ctc) + (λ (blame) + (let ([proj (pc blame)]) + (λ (val) + (if (struct-predicate-procedure? val) + val + (proj val))))))) + #:name (lambda (ctc) 'predicate/c) + #:first-order (let ([f (contract-struct-first-order predicate/c-private->ctc)]) (λ (ctc) f)) + #:stronger (λ (this that) (contract-struct-stronger? predicate/c-private->ctc that)))) + +(define -predicate/c (predicate/c)) diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index ae59117b08..39e80532b5 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -479,7 +479,7 @@ mutator-ids field-contract-ids)] [(predicate-code predicate-new-name) - (code-for-one-id/new-name stx predicate-id #f (syntax (-> any/c boolean?)) #f)] + (code-for-one-id/new-name stx predicate-id #f (syntax predicate/c) #f)] [(constructor-code constructor-new-name) (code-for-one-id/new-name stx diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 20ef416d0c..e4e827c394 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -761,6 +761,17 @@ be blamed using the above contract: (apply g (build-list i add1))) ]} +@defthing[predicate/c contract?]{ + Use this contract to indicate that some function + is a predicate. It is semantically equivalent to + @racket[(-> any/c boolean?)]. + + This contract also includes an optimization so that functions returning + @racket[#t] from @racket[struct-predicate-procedure?] are just returned directly, without + being wrapped. This contract is used by @racket[provide/contract]'s + @racket[struct] subform so that struct predicates end up not being wrapped. +} + @defthing[the-unsupplied-arg unsupplied-arg?]{ Used by @racket[->i] (and @racket[->d]) to bind optional arguments that are not supplied by a call site. @@ -781,7 +792,6 @@ The most convenient way to use parametric contract is to use The @racketmodname[racket/contract/parametric] provides a few more, general-purpose parametric contracts. - @defform[(parametric->/c (x ...) c)]{ Creates a contract for parametric polymorphic functions. Each function is diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 84786f443a..f69e496b97 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -1157,6 +1157,30 @@ (regexp-match #rx"expected keyword argument #:the-missing-keyword-arg-b" (exn-message x))))) + (test/pos-blame + 'predicate/c1 + '(contract predicate/c 1 'pos 'neg)) + (test/pos-blame + 'predicate/c2 + '(contract predicate/c (λ (x y) 1) 'pos 'neg)) + (test/pos-blame + 'predicate/c3 + '((contract predicate/c (λ (x) 1) 'pos 'neg) 12)) + (test/spec-passed + 'predicate/c4 + '((contract predicate/c (λ (x) #t) 'pos 'neg) 12)) + + ;; this test ensures that no contract wrappers + ;; are created for struct predicates + (test/spec-passed/result + 'predicate/c5 + '(let () + (struct x (a)) + (eq? (contract predicate/c x? 'pos 'neg) x?)) + #t) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; procedure accepts-and-more @@ -1176,7 +1200,6 @@ (ctest #t procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) (ctest #f procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0) - ; ; ; diff --git a/collects/unstable/contract.rkt b/collects/unstable/contract.rkt index 29a68c55e5..3d8df77dfb 100644 --- a/collects/unstable/contract.rkt +++ b/collects/unstable/contract.rkt @@ -180,7 +180,6 @@ (define thunk/c (-> any/c)) (define unary/c (-> any/c any/c)) (define binary/c (-> any/c any/c any/c)) -(define predicate/c (-> any/c boolean?)) (define comparison/c (-> any/c any/c boolean?)) (define predicate-like/c (-> any/c truth/c)) (define comparison-like/c (-> any/c any/c truth/c)) @@ -426,7 +425,6 @@ [thunk/c contract?] [unary/c contract?] [binary/c contract?] - [predicate/c contract?] [comparison/c contract?] [predicate-like/c contract?] [comparison-like/c contract?] diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl index 216d37d737..0f1bb3cdcd 100644 --- a/collects/unstable/scribblings/contract.scrbl +++ b/collects/unstable/scribblings/contract.scrbl @@ -154,18 +154,10 @@ respectively, and produce a single result. } @deftogether[( -@defthing[predicate/c contract?] @defthing[predicate-like/c contract?] )]{ -These contracts recognize predicates: functions of a single argument that -produce a boolean result. - -The first constrains its output to satisfy @racket[boolean?]. Use -@racket[predicate/c] in positive position for predicates that guarantee a result -of @racket[#t] or @racket[#f]. - -The second constrains its output to satisfy @racket[truth/c]. Use +This contract recognizes unary functions whose results satisfy @racket[truth/c]. Use @racket[predicate-like/c] in negative position for predicates passed as arguments that may return arbitrary values as truth values.