diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 0ba6295bd7..5b386ce3be 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -2819,6 +2819,53 @@ currently being checked. @history[#:added "6.1.1.5"] } +@defproc[(rename-contract [contract contract?] + [name any/c]) + contract?]{ + Produces a contract that acts like @racket[contract] but with the name + @racket[name]. + + The resulting contract is a flat contract if @racket[contract] is a + flat contract. + + @history[#:added "6.2.900.15"] +} + +@defproc[(if/c [predicate (-> any/c any/c)] + [then-contract contract?] + [else-contract contract?]) + contract?]{ + Produces a contract that, when applied to a value, first tests the + value with @racket[predicate]; if @racket[predicate] returns true, the + @racket[then-contract] is applied; otherwise, the + @racket[else-contract] is applied. The resulting contract is a flat + contract if both @racket[then-contract] and @racket[else-contract] are + flat contracts. + + For example, the following contract enforces that if a value is a + procedure, it is a thunk; otherwise it can be any (non-procedure) + value: + @racketblock[(if/c procedure? (-> any) any/c)] + Note that the following contract is @bold{not} equivalent: + @racketblock[(or/c (-> any) any/c) (code:comment "wrong!")] + The last contract is the same as @racket[any/c] because + @racket[or/c] tries flat contracts before higher-order contracts. + + @history[#:added "6.2.900.15"] +} + +@defthing[failure-result/c contract?]{ + A contract that describes the failure result arguments of procedures + such as @racket[hash-ref]. + + Equivalent to @racket[(if/c procedure? (-> any) any/c)]. + + @history[#:added "6.2.900.15"] +} + + + + @section{@racketmodname[racket/contract/base]} @defmodule[racket/contract/base] diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index 8ec36b86b8..857b341d67 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -68,4 +68,14 @@ list-contract? ;; from private/case-arrow.rkt - case->) + case-> + + ;; from here (needs `->`, so can't be deeper) + failure-result/c) + +;; failure-result/c : contract +;; Describes the optional failure argument passed to hash-ref, for example. +;; If the argument is a procedure, it must be a thunk, and it is applied. Otherwise +;; the argument is simply the value to return. +(define failure-result/c + (if/c procedure? (-> any) any/c)) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index b65f3756b0..2adcd4cedb 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -64,7 +64,10 @@ blame-add-cdr-context raise-not-cons-blame-error - random-any/c) + random-any/c + + rename-contract + if/c) (define-syntax (flat-murec-contract stx) (syntax-case stx () @@ -2155,3 +2158,62 @@ (listof any/c) (cons/c any/c any/c) (list/c)) + +;; rename-contract : contract any/c -> contract +;; If the argument is a flat contract, so is the result. +(define (rename-contract ctc name) + (unless (contract? ctc) + (raise-type-error 'rename-contract "contract?" ctc)) + (let ([ctc (coerce-contract 'rename-contract ctc)]) + (if (flat-contract? ctc) + (flat-named-contract name (flat-contract-predicate ctc)) + (let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)]) + (define (stronger? this other) + (contract-stronger? ctc other)) + (make-contract #:name name + #:projection (contract-projection ctc) + #:first-order (contract-first-order ctc) + #:stronger stronger? + #:list-contract? (list-contract? ctc)))))) + +;; (if/c predicate then/c else/c) applies then/c to satisfying +;; predicate, else/c to those that don't. +(define (if/c predicate then/c else/c) + #| + Naive version: + (or/c (and/c predicate then/c) + (and/c (not/c predicate) else/c)) + But that applies predicate twice. + |# + (unless (procedure? predicate) + (raise-type-error 'if/c "procedure?" predicate)) + (unless (contract? then/c) + (raise-type-error 'if/c "contract?" then/c)) + (unless (contract? else/c) + (raise-type-error 'if/c "contract?" else/c)) + (let ([then-ctc (coerce-contract 'if/c then/c)] + [else-ctc (coerce-contract 'if/c else/c)]) + (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc)) + ;; Special case: if both flat contracts, make a flat contract. + (if (and (flat-contract? then-ctc) + (flat-contract? else-ctc)) + ;; flat contract + (let ([then-pred (flat-contract-predicate then-ctc)] + [else-pred (flat-contract-predicate else-ctc)]) + (define (pred x) + (if (predicate x) (then-pred x) (else-pred x))) + (flat-named-contract name pred)) + ;; ho contract + (let ([then-proj (contract-projection then-ctc)] + [then-fo (contract-first-order then-ctc)] + [else-proj (contract-projection else-ctc)] + [else-fo (contract-first-order else-ctc)]) + (define ((proj blame) x) + (if (predicate x) + ((then-proj blame) x) + ((else-proj blame) x))) + (make-contract + #:name name + #:projection proj + #:first-order + (lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))