(module typed-scheme mzscheme
(require "private/prims.ss" "private/init-envs.ss" "private/extra-procs.ss" "private/internal-forms.ss" "private/base-env.ss")
(require-for-template "private/prims.ss" "private/extra-procs.ss" "private/internal-forms.ss" "private/base-env.ss" mzscheme)
(require-for-syntax "private/typechecker.ss"
"private/type-rep.ss"
"private/type-environments.ss" "private/tc-utils.ss"
"private/type-env.ss" "private/type-name-env.ss"
"private/base-env.ss"
"private/utils.ss"
"private/internal-forms.ss"
"private/init-envs.ss"
"private/type-effect-convenience.ss"
"private/effect-rep.ss"
(lib "kerncase.ss" "syntax")
(lib "list.ss")
(lib "plt-match.ss"))
(provide
(all-from "private/prims.ss")
(all-from "private/extra-procs.ss"))
(provide-tnames)
(provide-extra-tnames)
(provide (all-from-except mzscheme with-handlers #%module-begin #%top-interaction))
(provide (rename module-begin #%module-begin)
(rename with-handlers: with-handlers)
(rename top-interaction #%top-interaction))
(begin-for-syntax
(initialize-type-env initial-env)
(initialize-type-name-env initial-type-names)
(initialize-others))
(define-for-syntax catch-errors? #f)
(define-for-syntax (remove-provides forms)
(filter
(lambda (f) (kernel-syntax-case f #f
[(provide . _) #f]
[_ #t]))
(syntax->list forms)))
(define-syntax (module-begin stx)
(define module-name (syntax-property stx 'enclosing-module-name))
(with-logging-to-file (log-file-name (syntax-src stx) module-name)
(syntax-case stx ()
((mb forms ...)
(begin
(set-box! typed-context? #t)
(start-timing module-name)
(call-with-exception-handler
(lambda (e)
(if (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e)))
(with-handlers ([values values])
(tc-error "Internal error: ~a" e))
e))
(lambda ()
(parameterize ( [current-tvars initial-tvar-env]
[current-type-names
(lambda () (type-name-env-map (lambda (id ty)
(cons (syntax-e id) ty))))])
(do-time "Initialized Envs")
(with-syntax* ( [(pmb rfs body2 ...)
(local-expand #`(#%plain-module-begin
#,(syntax-local-introduce #'(require-for-syntax mzscheme))
forms ...)
'module-begin
null
stop-list)]
[__ (do-time "Local Expand Done")]
[extra-code (type-check #'(body2 ...))]
[(transformed-body2 ...) (remove-provides #'(body2 ...))])
(do-time "Typechecked")
(printf "checked ~a~n" module-name)
#'(pmb rfs transformed-body2 ... extra-code))))))))))
(define-syntax (top-interaction stx)
(syntax-case stx (module)
[(_ module . rest) #'(module . rest)]
((_ . form)
(begin
(set-box! typed-context? #t)
(parameterize ( [current-tvars initial-tvar-env]
[current-type-names
(lambda () (type-name-env-map (lambda (id ty)
(cons (syntax-e id) ty))))])
(let* ( [body2 (local-expand #'(#%top-interaction . form) 'top-level null)]
[type (tc-toplevel-form body2)])
(define x 3)
(kernel-syntax-case body2 ()
[(head . _)
(or (module-identifier=? #'head #'define-values)
(module-identifier=? #'head #'define-syntaxes)
(module-identifier=? #'head #'require)
(module-identifier=? #'head #'provide)
(module-identifier=? #'head #'require-for-template)
(module-identifier=? #'head #'require-for-syntax)
(module-identifier=? #'head #'begin))
body2]
[_ (with-syntax ([b body2]
[ty-str (match type
[(tc-result: t thn els)
(format "- : ~a\n" t)]
[x (printf "~a~n" x) ""])])
(if (equal? -Void (tc-result-t type))
#'b
#`(let ([v b] [type 'ty-str])
(begin0
v
(printf ty-str)))))])))))))
)