diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt new file mode 100644 index 00000000..79f8abfd --- /dev/null +++ b/collects/typed-scheme/tc-setup.rkt @@ -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))))))) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 269fd6e1..da080236 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -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 diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 586744c1..95ab29d3 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -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))]))]))