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

Make with-type disarm/arm the body expressions.

Browse Source 
Closes PR 14587.
This commit is contained in:
Eric Dobson 2014-07-05 17:58:03 -07:00
parent ab92f38f3b
commit 7ba4e1a8c1
2 changed files with 31 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -28,6 +28,8 @@
"env/global-env.rkt"
"env/tvar-env.rkt"
"utils/tc-utils.rkt"
"utils/disarm.rkt"
"utils/arm.rkt"
"types/utils.rkt"))
(provide wt-core)
@ -67,13 +69,14 @@
[ty (in-list fv-types)])
(register-type i ty))
(define expanded-body
(if expr?
(with-syntax ([body body])
(local-expand #'(let () . body) ctx null))
(with-syntax ([(body ...) body]
[(id ...) exids]
[(ty ...) extys])
(local-expand #'(let () (begin (: id ty) ... body ... (values id ...))) ctx null))))
(disarm*
(if expr?
(with-syntax ([body body])
(local-expand #'(let () . body) ctx null))
(with-syntax ([(body ...) body]
[(id ...) exids]
[(ty ...) extys])
(local-expand #'(let () (begin (: id ty) ... body ... (values id ...))) ctx null)))))
(parameterize (;; do we report multiple errors
[delay-errors? #t]
;; this parameter is just for printing types
@ -108,19 +111,20 @@
#'(void)
'disappeared-binding (disappeared-bindings-todo))
'disappeared-use (disappeared-use-todo))])
(if expr?
(quasisyntax/loc stx
(begin check-syntax-help
(c:with-contract typed-region
#:results (region-cnt ...)
#:freevars ([fv.id cnt] ...)
body)))
(syntax/loc stx
(begin
(define-values () (begin check-syntax-help (values)))
(c:with-contract typed-region
([ex-id ex-cnt] ...)
(define-values (ex-id ...) body)))))))
(arm
(if expr?
(quasisyntax/loc stx
(begin check-syntax-help
(c:with-contract typed-region
#:results (region-cnt ...)
#:freevars ([fv.id cnt] ...)
body)))
(syntax/loc stx
(begin
(define-values () (begin check-syntax-help (values)))
(c:with-contract typed-region
([ex-id ex-cnt] ...)
(define-values (ex-id ...) body))))))))
(define (wt-core stx)
(define-syntax-class typed-id

7
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr14587.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket
(require typed/racket)
(with-type #:result Any
(for/fold ([prod : Natural 1])
([x : Natural '(1 2 3 4 5)])
(* x prod)))