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

Allow uses of recursive-contract to specify the type of contract to create.

Browse Source
This commit is contained in:
Stevie Strickland 2010-12-07 17:53:12 -05:00
parent dd081d9b4e
commit 37349ca053
3 changed files with 76 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
collects/racket/contract/private/base.rkt
View File

@ -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))]))

8
collects/scribblings/reference/contracts.scrbl
View File

@ -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)]{

33
collects/tests/racket/contract-test.rktl
View File

@ -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))