diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt index fa1ae276cb..93a20aa6fe 100644 --- a/collects/racket/contract/private/base.rkt +++ b/collects/racket/contract/private/base.rkt @@ -69,17 +69,41 @@ improve method arity mismatch contract violation error messages? (define-syntax (recursive-contract stx) (syntax-case stx () + [(_ arg type) + (keyword? (syntax-e #'type)) + (with-syntax ([maker + (case (syntax-e #'type) + [(#:impersonator) #'make-contract] + [(#:chaperone) #'make-chaperone-contract] + [(#:flat) #'make-flat-contract] + [else (raise-syntax-error 'recursive-contract + "type must be one of #:impersonator, #:chaperone, or #:flat" + #'type)])] + [coerce + (case (syntax-e #'type) + [(#:impersonator) #'coerce-contract] + [(#:chaperone) #'coerce-chaperone-contract] + [(#:flat) #'coerce-flat-contract] + [else (raise-syntax-error 'recursive-contract + "type must be one of #:impersonator, #:chaperone, or #:flat" + #'type)])] + [(type ...) + (if (eq? (syntax-e #'type) '#:impersonator) + null + (list #'type))]) + (syntax + (maker + #:name '(recursive-contract arg type ...) + #:first-order + (λ (val) + (let ([ctc (coerce 'recursive-contract arg)]) + (contract-first-order-passes? ctc val))) + #:projection + (λ (blame) + (let ([ctc (coerce 'recursive-contract arg)]) + (let ([f (contract-projection ctc)]) + (λ (val) + ((f blame) val))))))))] [(_ arg) - (syntax - (make-contract - #:name '(recursive-contract arg) - #:first-order - (λ (val) - (let ([ctc (coerce-contract 'recursive-contract arg)]) - (contract-first-order-passes? ctc val))) - #:projection - (λ (blame) - (let ([ctc (coerce-contract 'recursive-contract arg)]) - (let ([f (contract-projection ctc)]) - (λ (val) - ((f blame) val)))))))])) + (syntax/loc stx + (recursive-contract arg #:impersonator))])) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index f30874347c..d67c4f1a13 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -1792,10 +1792,14 @@ the message that indicates the violation. } -@defform[(recursive-contract contract-expr)]{ +@defform*[[(recursive-contract contract-expr) + (recursive-contract contract-expr type)]]{ Delays the evaluation of its argument until the contract is checked, -making recursive contracts possible.} +making recursive contracts possible. If @racket[type] is given, it +describes the expected type of contract and must be one of the keywords +@racket[#:impersonator], @racket[#:chaperone], or @racket[#:flat]. If +@racket[type] is not given, an impersonator contract is created.} @defform[(opt/c contract-expr)]{ diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 2d9d270441..1f67cb4dce 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -8097,6 +8097,26 @@ 'pos 'neg)) + (test/spec-passed + 'recursive-contract6 + '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) + (contract ctc (cons 1 (cons 2 3)) 'pos 'neg))) + + (test/pos-blame + 'recursive-contract7 + '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) + (contract ctc (cons 1 (cons 2 #t)) 'pos 'neg))) + + (test/pos-blame + 'recursive-contract8 + '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) + (contract ctc (cons 1 (cons #t 3)) 'pos 'neg))) + + (test/spec-passed + 'recursive-contract9 + '(letrec ([ctc (or/c number? (hash/c (recursive-contract ctc #:chaperone) number?))]) + (make-hash (list (cons (make-hash (list (cons 3 4))) 5))))) + ; @@ -9108,6 +9128,19 @@ so that propagation occurs. (ctest #t contract? (box/c trivial-proxy-ctc #:immutable #t)) (ctest #f chaperone-contract? (box/c trivial-proxy-ctc #:immutable #t)) (ctest #f flat-contract? (box/c trivial-proxy-ctc #:immutable #t)) + + ;; Test the ability to create different types of contracts with recursive-contract + (ctest #t flat-contract? (letrec ([ctc (or/c number? + (cons/c (recursive-contract ctc #:flat) + (recursive-contract ctc #:flat)))]) + ctc)) + + (ctest #f flat-contract? (letrec ([ctc (or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) + (ctest #t chaperone-contract? (letrec ([ctc (or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) (ctest #t contract? 1) (ctest #t contract? (-> 1 1))