From feeb6c9163761f370b35b4c9fde033d6ab9efe07 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 15 Dec 2013 10:32:31 -0800 Subject: [PATCH] Add tc-toplevel/full and tc-module/full and use them. --- .../typed-racket/base-env/top-interaction.rkt | 62 ++++++------ .../typed-racket-lib/typed-racket/core.rkt | 96 +++++++++---------- .../typed-racket/tc-setup.rkt | 20 +++- .../typed-racket/typecheck/tc-toplevel.rkt | 14 ++- 4 files changed, 99 insertions(+), 93 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt index 97dded8df1..41897e241c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt @@ -77,14 +77,14 @@ (define (:print-type-impl stx) (syntax-parse stx [(_ e) - (tc-setup stx #'e 'top-level tc-toplevel-form - (lambda (expanded before type) - #`(display - #,(parameterize ([print-multi-line-case-> #t]) - (format "~a\n" (match type - [(tc-result1: t f o) t] - [(tc-results: t) (-values t)] - [(tc-any-results:) ManyUniv]))))))] + (tc-toplevel/full stx #'e + (λ (expanded type) + #`(display + #,(parameterize ([print-multi-line-case-> #t]) + (format "~a\n" (match type + [(tc-result1: t f o) t] + [(tc-results: t) (-values t)] + [(tc-any-results:) ManyUniv]))))))] [form (raise-syntax-error #f "must be applied to exactly one argument" #'form)])) @@ -93,17 +93,17 @@ (syntax-parse stx [(_ op arg-type ...) (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) - (tc-setup stx - ;; create a dummy function with the right argument types - #`(lambda #,(stx-map type-label-property - #'(dummy-arg ...) #'(arg-type ...)) - (op dummy-arg ...)) - 'top-level tc-toplevel-form - (lambda (expanded before type) - #`(display - #,(format "~a\n" - (match type - [(tc-result1: (and t (Function: _)) f o) t]))))))] + (tc-toplevel/full + stx + ;; create a dummy function with the right argument types + #`(lambda #,(stx-map type-label-property + #'(dummy-arg ...) #'(arg-type ...)) + (op dummy-arg ...)) + (λ (expanded type) + #`(display + #,(format "~a\n" + (match type + [(tc-result1: (and t (Function: _)) f o) t]))))))] [form (raise-syntax-error #f "must be applied to at least one argument" #'form)])) @@ -112,17 +112,17 @@ (syntax-parse stx [(_ op desired-type) (let ([expected (parse-type #'desired-type)]) - (tc-setup stx #'op 'top-level tc-toplevel-form - (lambda (expanded before type) - (match type - [(tc-result1: (and t (Function: _)) f o) - (let ([cleaned (cleanup-type t expected)]) - #`(display - #,(match cleaned - [(Function: '()) - "Desired return type not in the given function's range.\n"] - [(Function: arrs) - (format "~a\n" cleaned)])))] - [_ (error (format "~a: not a function" (syntax->datum #'op)))]))))] + (tc-toplevel/full stx #'op + (λ (expanded type) + (match type + [(tc-result1: (and t (Function: _)) f o) + (let ([cleaned (cleanup-type t expected)]) + #`(display + #,(match cleaned + [(Function: '()) + "Desired return type not in the given function's range.\n"] + [(Function: arrs) + (format "~a\n" cleaned)])))] + [_ (error (format "~a: not a function" (syntax->datum #'op)))]))))] [form (raise-syntax-error #f "must be applied to exactly two arguments" #'form)]))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt index 405ed62348..0a134578e8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt @@ -24,8 +24,7 @@ (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) (parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?)) (and (attribute opt?) (syntax-e (attribute opt?))))]) - (tc-setup - stx pmb-form 'module-begin tc-module + (tc-module/full stx pmb-form (λ (new-mod before-code after-code) (with-syntax* (;; pmb = #%plain-module-begin @@ -61,50 +60,49 @@ ;; TODO(endobson): Remove the call to do-standard-inits when it is no longer necessary ;; Cast at the top-level still needs this for some reason (do-standard-inits) - (tc-setup - stx #'form 'top-level tc-toplevel-form - (λ (body2 before type) - (with-syntax* - ([(optimized-body . _) (maybe-optimize #`(#,body2))]) - (syntax-parse body2 - ;; any of these do not produce an expression to be printed - [(head:invis-kw . _) (arm #'optimized-body)] - [_ (let ([ty-str (match type - ;; don't print results of type void - [(tc-result1: (== -Void type-equal?)) - #f] - ;; don't print results of unknown type - [(tc-any-results:) - #f] - [(tc-result1: t f o) - ;; Don't display the whole types at the REPL. Some case-lambda types - ;; are just too large to print. - ;; Also, to avoid showing too precise types, we generalize types - ;; before printing them. - (define tc (cleanup-type t)) - (define tg (generalize tc)) - (format "- : ~a~a~a\n" - tg - (cond [(equal? tc tg) ""] - [else (format " [more precisely: ~a]" tc)]) - (cond [(equal? tc t) ""] - [did-I-suggest-:print-type-already? " ..."] - [else (set! did-I-suggest-:print-type-already? #t) - :print-type-message]))] - [(tc-results: t) - (define tcs (map cleanup-type t)) - (define tgs (map generalize tcs)) - (format "- : ~a~a~a\n" - (cons 'Values tgs) - (cond [(andmap equal? tgs tcs) ""] - [else (format " [more precisely: ~a]" (cons 'Values tcs))]) - ;; did any get pruned? - (cond [(andmap equal? t tcs) ""] - [did-I-suggest-:print-type-already? " ..."] - [else (set! did-I-suggest-:print-type-already? #t) - :print-type-message]))] - [x (int-err "bad type result: ~a" x)])]) - (if ty-str - #`(let ([type '#,ty-str]) - (begin0 #,(arm #'optimized-body) (display type))) - (arm #'optimized-body)))]))))])) + (tc-toplevel/full stx #'form + (λ (body2 type) + (with-syntax* + ([(optimized-body . _) (maybe-optimize #`(#,body2))]) + (syntax-parse body2 + ;; any of these do not produce an expression to be printed + [(head:invis-kw . _) (arm #'optimized-body)] + [_ (let ([ty-str (match type + ;; don't print results of type void + [(tc-result1: (== -Void type-equal?)) + #f] + ;; don't print results of unknown type + [(tc-any-results:) + #f] + [(tc-result1: t f o) + ;; Don't display the whole types at the REPL. Some case-lambda types + ;; are just too large to print. + ;; Also, to avoid showing too precise types, we generalize types + ;; before printing them. + (define tc (cleanup-type t)) + (define tg (generalize tc)) + (format "- : ~a~a~a\n" + tg + (cond [(equal? tc tg) ""] + [else (format " [more precisely: ~a]" tc)]) + (cond [(equal? tc t) ""] + [did-I-suggest-:print-type-already? " ..."] + [else (set! did-I-suggest-:print-type-already? #t) + :print-type-message]))] + [(tc-results: t) + (define tcs (map cleanup-type t)) + (define tgs (map generalize tcs)) + (format "- : ~a~a~a\n" + (cons 'Values tgs) + (cond [(andmap equal? tgs tcs) ""] + [else (format " [more precisely: ~a]" (cons 'Values tcs))]) + ;; did any get pruned? + (cond [(andmap equal? t tcs) ""] + [did-I-suggest-:print-type-already? " ..."] + [else (set! did-I-suggest-:print-type-already? #t) + :print-type-message]))] + [x (int-err "bad type result: ~a" x)])]) + (if ty-str + #`(let ([type '#,ty-str]) + (begin0 #,(arm #'optimized-body) (display type))) + (arm #'optimized-body)))]))))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt index 75dc6af337..49b49d6846 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt @@ -9,8 +9,11 @@ (for-syntax racket/base) (for-template racket/base)) (lazy-require [typed-racket/optimizer/optimizer (optimize-top)]) +(lazy-require [typed-racket/typecheck/tc-toplevel (tc-toplevel-form tc-module)]) -(provide tc-setup invis-kw maybe-optimize init-current-type-names) +(provide invis-kw maybe-optimize init-current-type-names + tc-module/full + tc-toplevel/full) (define-syntax-class invis-kw #:literals (define-values define-syntaxes #%require @@ -39,7 +42,7 @@ (define-logger online-check-syntax) -(define (tc-setup orig-stx stx expand-ctxt checker f) +(define (tc-setup orig-stx stx expand-ctxt checker k) (set-box! typed-context? #t) ;(start-timing (syntax-property stx 'enclosing-module-name)) (with-handlers @@ -73,6 +76,13 @@ (parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)] [expanded-module-stx fully-expanded-stx]) (do-time "Starting `checker'") - (define-values (pre-result post-result) (checker fully-expanded-stx)) - (do-time "Typechecking Done") - (f fully-expanded-stx pre-result post-result))))) + (call-with-values (λ () (checker fully-expanded-stx)) + (λ results + (do-time "Typechecking Done") + (apply k fully-expanded-stx results))))))) + +(define (tc-toplevel/full orig-stx stx k) + (tc-setup orig-stx stx 'top-level tc-toplevel-form k)) + +(define (tc-module/full orig-stx stx k) + (tc-setup orig-stx stx 'module-begin tc-module k)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index b42dfdecba..5043896547 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -22,7 +22,7 @@ (provide/cond-contract [tc-module (syntax? . c:-> . (values syntax? syntax?))] - [tc-toplevel-form (syntax? . c:-> . (values #f c:any/c))]) + [tc-toplevel-form (syntax? . c:-> . c:any/c)]) (define unann-defs (make-free-id-table)) @@ -359,18 +359,16 @@ ;; typecheck a top-level form ;; used only from #%top-interaction -;; syntax -> (values #f (or/c void? tc-results/c)) +;; syntax -> (or/c void? tc-results/c) (define (tc-toplevel-form form) (syntax-parse form ;; Don't open up `begin`s that are supposed to be ignored [(~and ((~literal begin) e ...) (~not (~or _:ignore^ _:ignore-some^))) - (define result + (begin0 (for/last ([form (in-syntax #'(e ...))]) - (define-values (_ result) (tc-toplevel-form form)) - result)) - (begin0 (values #f result) - (report-all-errors))] + (tc-toplevel-form form)) + (report-all-errors))] [_ ;; Handle type aliases (when (type-alias? form) @@ -386,6 +384,6 @@ (refine-struct-variance! (list parsed)) (register-parsed-struct-bindings! parsed)) (tc-toplevel/pass1 form) - (begin0 (values #f (tc-toplevel/pass2 form)) + (begin0 (tc-toplevel/pass2 form) (report-all-errors))]))