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

improve the name of recursive-contract (thanks, Asumu!)

Browse Source 
closes PR 13686
This commit is contained in:
Robby Findler 2013-04-11 22:44:08 -05:00
parent 41d90c6dd5
commit a425ee5207
2 changed files with 33 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -72,6 +72,7 @@
(define-syntax (-recursive-contract stx)
(define (do-recursive-contract arg type name)
(define local-name (syntax-local-infer-name stx))
(with-syntax ([maker
(case (syntax-e type)
[(#:impersonator) #'impersonator-recursive-contract]
@ -81,7 +82,7 @@
"type must be one of #:impersonator, #:chaperone, or #:flat"
stx
type)])])
#`(maker '#,name (λ () #,arg) #f)))
#`(maker '#,name (λ () #,arg) '#,local-name)))
(syntax-case stx ()
[(_ arg type)
(keyword? (syntax-e #'type))
@ -92,9 +93,10 @@
(define (force-recursive-contract ctc)
(define current (recursive-contract-ctc ctc))
(cond
[current current]
[else
[(or (symbol? current) (not current))
(define thunk (recursive-contract-thunk ctc))
(define old-name (recursive-contract-name ctc))
(set-recursive-contract-name! ctc (or current '<recursive-contract>))
(define forced-ctc
(cond
[(flat-recursive-contract? ctc)
@ -104,7 +106,11 @@
[(impersonator-recursive-contract? ctc)
(coerce-contract 'recursive-contract (thunk))]))
(set-recursive-contract-ctc! ctc forced-ctc)
forced-ctc]))
(set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
(cddr old-name)))
forced-ctc]
[else current]))
(define ((recursive-contract-projection ctc) blame)
(define r-ctc (force-recursive-contract ctc))
(define f (contract-projection r-ctc))
@ -121,7 +127,8 @@
(contract-first-order-passes? (force-recursive-contract ctc)
val))
(struct recursive-contract (name thunk [ctc #:mutable]))
(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable]))
(struct flat-recursive-contract recursive-contract ()
#:property prop:flat-contract
(build-flat-contract-property
@ -142,4 +149,4 @@
#:name recursive-contract-name
#:first-order recursive-contract-first-order
#:projection recursive-contract-projection
#:stronger recursive-contract-stronger))
#:stronger recursive-contract-stronger))

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

@ -12461,7 +12461,27 @@ so that propagation occurs.
(struct/c st integer?)))
(test-name '(recursive-contract (box/c boolean?)) (recursive-contract (box/c boolean?)))
(test-name '(recursive-contract boolean? #:flat) (let ([c (recursive-contract boolean? #:flat)])
(contract c #f 'pos 'neg)
c))
(test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x)))
(test-name '(recursive-contract integeeer?)
(let ([x (box/c boolean?)])
(let ([c (recursive-contract (flat-named-contract 'integeeer? integer?))])
(contract c 1 'pos 'neg)
c)))
(test-name '(recursive-contract (or/c (flat-named-contract 'integeeer? integer?)
(listof c)))
(letrec ([c (recursive-contract
(or/c (flat-named-contract 'integeeer? integer?)
(listof c)))])
c))
(test-name '(recursive-contract (or/c integeeer? (listof c)))
(letrec ([c (recursive-contract
(or/c (flat-named-contract 'integeeer? integer?)
(listof c)))])
(contract c 1 'pos 'neg)
c))
(test-name '(couple/c any/c any/c)
(couple/c any/c any/c))