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

Struct types now generate flat contracts when appropriate.

Browse Source 
Closes PR 11686.
This commit is contained in:
Eric Dobson 2011-05-02 16:35:14 -04:00 committed by Sam Tobin-Hochstadt
parent 1bf95392d2
commit 613e121783
3 changed files with 78 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/tests/typed-scheme/fail/pr11686.rkt Normal file
View File

@ -0,0 +1,29 @@
#;
(exn-pred exn:fail:contract?)
#lang racket/load
(module T typed/racket
(struct: [X] doll ([contents : X]))
(define-type RussianDoll
(Rec RD (U 'center (doll RD))))
(: f (RussianDoll -> RussianDoll))
(define (f rd) rd)
(: md (All (x) (x -> (doll x))))
(define md doll)
(provide (all-defined-out)))
(module U racket
(require 'T)
(f (md 3)))
(require 'U)

15
collects/tests/typed-scheme/succeed/pr11686.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang racket/load
(module T typed/racket
(struct: [X] doll ([contents : X]))
(define-type RussianDoll
(Rec RD (U 'center (doll RD))))
(: f (RussianDoll -> RussianDoll))
(define (f rd) rd)
(provide (all-defined-out)))
(require 'T)

52
collects/typed-scheme/private/type-contract.rkt
View File

@ -237,26 +237,42 @@
[poly?
(with-syntax* ([(rec blame val) (generate-temporaries '(rec blame val))]
[maker maker-id]
[cnt-name nm]
[(fld-cnts ...)
(for/list ([fty flds]
[cnt-name nm])
;If it should be a flat contract, we make flat contracts for the type of each field,
;extract the predicates, and apply the predicates to the corresponding field value
(if flat?
#`(letrec ([rec
(make-flat-contract
#:name 'cnt-name
#:first-order
(lambda (val)
(and
(#,pred? val)
#,@(for/list ([fty flds] [f-acc acc-ids])
#`((flat-contract-predicate
#,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
(#,f-acc val))))))])
rec)
;Should make this case a chaperone/impersonator contract
(with-syntax ([(fld-cnts ...)
(for/list ([fty flds]
[f-acc acc-ids]
[m? mut?])
#`(((contract-projection
#,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
blame)
(#,f-acc val)))])
#`(letrec ([rec
(make-contract
#:name 'cnt-name
#:first-order #,pred?
#:projection
(lambda (blame)
(lambda (val)
(unless (#,pred? val)
(raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val))
(maker fld-cnts ...))))])
rec))]
#`(((contract-projection
#,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
blame)
(#,f-acc val)))])
#`(letrec ([rec
(make-contract
#:name 'cnt-name
#:first-order #,pred?
#:projection
(lambda (blame)
(lambda (val)
(unless (#,pred? val)
(raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val))
(maker fld-cnts ...))))])
rec))))]
[else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])]
[(Syntax: (Base: 'Symbol _ _ _)) #'identifier?]
[(Syntax: t) #`(syntax/c #,(t->c t))]