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

Refactor #%module-begin and #%top-interaction for Typed Scheme.

Browse Source 
original commit: 5f069ed4bb033531d39c8b268180f4ef70598c57
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-11 11:09:39 -04:00
parent dd84cab0b2
commit 589306a88f
3 changed files with 117 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/typed-scheme/tc-setup.rkt Normal file
View File

@ -0,0 +1,62 @@
#lang racket/base
(require (rename-in "utils/utils.rkt" [infer r:infer])
(except-in syntax/parse id)
unstable/mutated-vars
scheme/base
(private type-contract optimize)
(types utils convenience)
(typecheck typechecker provide-handling tc-toplevel)
(env type-environments type-name-env type-alias-env)
(r:infer infer)
(utils tc-utils)
(rep type-rep)
(except-in (utils utils) infer)
(only-in (r:infer infer-dummy) infer-param)
scheme/nest
syntax/kerncase
scheme/match
(for-syntax racket/base)
(for-template racket/base))
(provide tc-setup invis-kw)
(define-syntax-class invis-kw
#:literals (define-values define-syntaxes #%require #%provide begin)
(pattern (~or define-values define-syntaxes #%require #%provide begin)))
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body)
(let ()
(set-box! typed-context? #t)
(start-timing (syntax-property stx 'enclosing-module-name))
(with-handlers
([(lambda (e) (and #f (exn:fail? e) (not (exn:fail:syntax? e))))
(lambda (e) (tc-error "Internal Typed Racket Error : ~a" e))])
(parameterize (;; enable fancy printing?
[custom-printer #t]
;; a cheat to avoid units
[infer-param infer]
;; do we report multiple errors
[delay-errors? #t]
;; this parameter is for parsing types
[current-tvars initial-tvar-env]
;; this parameter is just for printing types
;; this is a parameter to avoid dependency issues
[current-type-names
(lambda ()
(append
(type-name-env-map (lambda (id ty)
(cons (syntax-e id) ty)))
(type-alias-env-map (lambda (id ty)
(cons (syntax-e id) ty)))))]
;; reinitialize seen type variables
[type-name-references null])
(do-time "Initialized Envs")
(let ([fully-expanded-stx (local-expand stx expand-ctxt null)])
(do-time "Local Expand Done")
(parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)]
[orig-module-stx (or (orig-module-stx) orig-stx)]
[expanded-module-stx fully-expanded-stx])
(let ([result (checker fully-expanded-stx)])
(do-time "Typechecking Done")
. body)))))))

9
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -26,7 +26,8 @@
scheme/base))
(c:provide/contract
[type-check (syntax? . c:-> . syntax?)]
[type-check (syntax? . c:-> . syntax?)]
[tc-module (syntax? . c:-> . syntax?)]
[tc-toplevel-form (syntax? . c:-> . c:any/c)])
(define unann-defs (make-free-id-table))
@ -277,6 +278,12 @@
#,(talias-env-init-code)
(begin new-provs ... ...)))))
;; typecheck a whole module
;; syntax -> syntax
(define (tc-module stx)
(syntax-parse stx
[(pmb . forms) (type-check #'forms)]))
;; typecheck a top-level form
;; used only from #%top-interaction
;; syntax -> void

171
collects/typed-scheme/typed-scheme.rkt
View File

@ -1,12 +1,10 @@
#lang scheme/base
(require (rename-in "utils/utils.rkt" [infer r:infer]))
(require (private with-types)
(require (rename-in "utils/utils.rkt" [infer r:infer])
(private with-types)
(for-syntax
(except-in syntax/parse id)
unstable/mutated-vars
scheme/base
unstable/syntax racket/base unstable/match
(private type-contract optimize)
(types utils convenience)
(typecheck typechecker provide-handling tc-toplevel)
@ -16,9 +14,8 @@
(rep type-rep)
(except-in (utils utils) infer)
(only-in (r:infer infer-dummy) infer-param)
scheme/nest
syntax/kerncase
scheme/match))
scheme/match
"tc-setup.rkt"))
(provide (rename-out [module-begin #%module-begin]
[top-interaction #%top-interaction]
@ -27,129 +24,55 @@
[require require])
with-type)
(define-for-syntax catch-errors? #f)
;(begin (init-tnames))
(define-syntax (module-begin stx)
(define module-name (syntax-property stx 'enclosing-module-name))
;(printf "BEGIN: ~a~n" (syntax->datum stx))
(syntax-parse stx
[(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...)
(nest
([begin (set-box! typed-context? #t)
(start-timing module-name)]
[with-handlers
([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e))))
(lambda (e) (tc-error "Internal error: ~a" e))])]
[parameterize (;; enable fancy printing?
[custom-printer #t]
;; a cheat to avoid units
[infer-param infer]
;; do we report multiple errors
[delay-errors? #t]
;; do we optimize?
[optimize? (or (attribute opt?) (optimize?))]
;; this parameter is for parsing types
[current-tvars initial-tvar-env]
;; this parameter is just for printing types
;; this is a parameter to avoid dependency issues
[current-type-names
(lambda ()
(append
(type-name-env-map (lambda (id ty)
(cons (syntax-e id) ty)))
(type-alias-env-map (lambda (id ty)
(cons (syntax-e id) ty)))))]
;; reinitialize seen type variables
[type-name-references null])]
[begin (do-time "Initialized Envs")]
;; local-expand the module
;; pmb = #%plain-module-begin
[with-syntax ([new-mod
(local-expand (syntax/loc stx
(#%plain-module-begin
forms ...))
'module-begin
null)])]
[parameterize ([mutated-vars (find-mutated-vars #'new-mod)])]
[with-syntax ([(pmb body2 ...) #'new-mod])]
[begin (do-time "Local Expand Done")]
[with-syntax ([after-code (parameterize ([orig-module-stx (or (orig-module-stx) stx)]
[expanded-module-stx #'new-mod])
(type-check #'(body2 ...)))]
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
[(transformed-body ...) (remove-provides #'(body2 ...))])]
[with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])]
[with-syntax ([(transformed-body ...)
(if (optimize?)
(begin (printf "optimizing ...\n")
(map optimize (syntax->list #'(transformed-body ...))))
#'(transformed-body ...))])])
(do-time "Typechecked")
#;(printf "checked ~a~n" module-name)
#;(printf "created ~a types~n" (count!))
#;(printf "tried to create ~a types~n" (all-count!))
#;(printf "created ~a union types~n" (union-count!))
(let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))])
(tc-setup
stx pmb-form 'module-begin new-mod tc-module after-code
(with-syntax*
(;; pmb = #%plain-module-begin
[(pmb . body2) new-mod]
;; add in syntax property on useless expression to draw check-syntax arrows
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
;; perform the provide transformation from [Culpepper 07]
[transformed-body (remove-provides #'body2)]
;; add the real definitions of contracts on requires
[transformed-body (change-contract-fixups #'transformed-body)]
;; potentially optimize the code based on the type information
[(optimized-body ...)
;; do we optimize?
(if (or (attribute opt?) (optimize?))
(begin (printf "optimizing ...\n")
(begin0 (map optimize (syntax->list #'transformed-body))
(do-time "Optimized")))
#'transformed-body)])
;; reconstruct the module with the extra code
#'(#%module-begin transformed-body ... after-code check-syntax-help))]))
;; use the regular %#module-begin from `racket/base' for top-level printing
#`(#%module-begin optimized-body ... #,after-code check-syntax-help))))]))
(define-syntax (top-interaction stx)
(syntax-case stx ()
[(_ . (module . rest))
(eq? 'module (syntax-e #'module))
(syntax-parse stx
[(_ . ((~datum module) . rest))
#'(module . rest)]
[(_ . form)
(nest
([begin (set-box! typed-context? #t)]
[parameterize (;; disable fancy printing
[custom-printer #t]
;; a cheat to avoid units
[infer-param infer]
;; this paramter is for parsing types
[current-tvars initial-tvar-env]
;; this parameter is just for printing types
;; this is a parameter to avoid dependency issues
[current-type-names
(lambda ()
(append
(type-name-env-map (lambda (id ty)
(cons (syntax-e id) ty)))
(type-alias-env-map (lambda (id ty)
(cons (syntax-e id) ty)))))])]
;(do-time "Initialized Envs")
;; local-expand the module
[let ([body2 (local-expand #'(#%top-interaction . form) 'top-level null)])]
[parameterize ([orig-module-stx #'form]
[expanded-module-stx body2]
[mutated-vars (find-mutated-vars body2)])]
;; typecheck the body, and produce syntax-time code that registers types
[let ([type (tc-toplevel-form body2)])])
(define-syntax-class invis-kw
#:literals (define-values define-syntaxes #%require #%provide begin)
(pattern define-values)
(pattern define-syntaxes)
(pattern #%require)
(pattern #%provide)
(pattern begin))
(syntax-parse body2
[(head:invis-kw . _)
body2]
[_ (let ([ty-str (match type
[(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #f]
[(tc-result1: t f o)
(format "- : ~a\n" t)]
[(tc-results: t)
(format "- : ~a\n" (cons 'Values t))]
[x (int-err "bad type result: ~a" x)])])
(if ty-str
#`(let ([type '#,ty-str])
(begin0
#,body2
(display type)))
body2))]))]))
[(_ . form)
(tc-setup
stx #'form 'top-level body2 tc-toplevel-form type
(syntax-parse body2
;; any of these do not produce an expression to be printed
[(head:invis-kw . _) body2]
[_ (let ([ty-str (match type
;; don't print results of type void
[(tc-result1: (== -Void type-equal?)) #f]
[(tc-result1: t f o)
(format "- : ~a\n" t)]
[(tc-results: t)
(format "- : ~a\n" (cons 'Values t))]
[x (int-err "bad type result: ~a" x)])])
(if ty-str
#`(let ([type '#,ty-str])
(begin0 #,body2 (display type)))
body2))]))]))