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

Fix cast/make-predicate contracts in with-type

Browse Source
This commit is contained in:
Asumu Takikawa 2014-07-25 15:57:35 -04:00
parent 0e8e71f48f
commit 4ead2124c7
2 changed files with 11 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt
View File

@ -117,6 +117,8 @@
#'(void) #'(void)
'disappeared-binding (disappeared-bindings-todo)) 'disappeared-binding (disappeared-bindings-todo))
'disappeared-use (disappeared-use-todo))]) 'disappeared-use (disappeared-use-todo))])
(define fixed-up-definitions
(change-contract-fixups lifted-definitions))
(arm (arm
(if expr? (if expr?
(quasisyntax/loc stx (quasisyntax/loc stx
@ -124,14 +126,14 @@
(c:with-contract typed-region (c:with-contract typed-region
#:results (region-cnt ...) #:results (region-cnt ...)
#:freevars ([fv.id cnt] ...) #:freevars ([fv.id cnt] ...)
#,lifted-definitions #,fixed-up-definitions
body))) body)))
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define-values () (begin check-syntax-help (values))) (define-values () (begin check-syntax-help (values)))
(c:with-contract typed-region (c:with-contract typed-region
([ex-id ex-cnt] ...) ([ex-id ex-cnt] ...)
#,lifted-definitions #,fixed-up-definitions
(define-values (ex-id ...) body)))))))) (define-values (ex-id ...) body))))))))
;; Syntax (U Symbol List) -> (values Syntax Syntax) ;; Syntax (U Symbol List) -> (values Syntax Syntax)

7
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/with-type-lift.rkt
View File

@ -16,3 +16,10 @@
(with-type ([val Number]) (define val (m2))) (with-type ([val Number]) (define val (m2)))
(check-equal? val 3) (check-equal? val 3)
(with-type #:result (Listof String)
;; casts do lifts for the contract
(define x (cast '() (Listof String)))
;; as do predicates
(make-predicate (Listof String))
x)