From c8c5c12ae2ae7fd311866eef42d19375b10cd858 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 15 Dec 2013 01:08:53 -0800 Subject: [PATCH] Make tc-setup just take a function instead of 3 identifiers. original commit: f6ef86d7db520b5ebcfea694c135e525164d37e6 --- .../typed-racket/base-env/top-interaction.rkt | 46 ++++--- .../typed-racket-lib/typed-racket/core.rkt | 130 +++++++++--------- .../typed-racket/tc-setup.rkt | 8 +- 3 files changed, 91 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 d0d07078..704b268f 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,16 +77,17 @@ ;; Prints the _entire_ type. May be quite large. (define (:print-type-impl stx init) (syntax-parse stx - [(_ e) - (tc-setup stx #'e 'top-level expanded init tc-toplevel-form before type + [(_ e) + (tc-setup stx #'e 'top-level init 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])))))] - [form - (raise-syntax-error #f "must be applied to exactly one argument" #'form)])) + [(tc-any-results:) ManyUniv]))))))] + [form + (raise-syntax-error #f "must be applied to exactly one argument" #'form)])) ;; given a function and input types, display the result type (define (:query-type/args-impl stx init) @@ -98,11 +99,12 @@ #`(lambda #,(stx-map type-label-property #'(dummy-arg ...) #'(arg-type ...)) (op dummy-arg ...)) - 'top-level expanded init tc-toplevel-form before type - #`(display - #,(format "~a\n" - (match type - [(tc-result1: (and t (Function: _)) f o) t])))))] + 'top-level init tc-toplevel-form + (lambda (expanded before 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 +114,17 @@ [(_ op desired-type) (init) (let ([expected (parse-type #'desired-type)]) - (tc-setup stx #'op 'top-level expanded init tc-toplevel-form 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-setup stx #'op 'top-level init 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)))]))))] [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 d1325fc6..9c16e09b 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,25 +24,26 @@ (parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?)) (and (attribute opt?) (syntax-e (attribute opt?))))]) (tc-setup - stx pmb-form 'module-begin new-mod init tc-module before-code after-code - (with-syntax* - (;; pmb = #%plain-module-begin - [(pmb . body2) new-mod] - ;; perform the provide transformation from [Culpepper 07] - [transformed-body (begin0 (remove-provides #'body2) (do-time "Removed provides"))] - ;; add the real definitions of contracts on requires - [transformed-body (begin0 (change-contract-fixups #'transformed-body) (do-time "Fixed contract ids"))] - ;; potentially optimize the code based on the type information - [(optimized-body ...) (maybe-optimize #'transformed-body)] ;; has own call to do-time - ;; add in syntax property on useless expression to draw check-syntax arrows - [check-syntax-help (syntax-property - (syntax-property - #'(void) - 'disappeared-binding (disappeared-bindings-todo)) - 'disappeared-use (disappeared-use-todo))]) - ;; reconstruct the module with the extra code - ;; use the regular %#module-begin from `racket/base' for top-level printing - (arm #`(#%module-begin #,before-code optimized-body ... #,after-code check-syntax-help))))))])) + stx pmb-form 'module-begin init tc-module + (λ (new-mod before-code after-code) + (with-syntax* + (;; pmb = #%plain-module-begin + [(pmb . body2) new-mod] + ;; perform the provide transformation from [Culpepper 07] + [transformed-body (begin0 (remove-provides #'body2) (do-time "Removed provides"))] + ;; add the real definitions of contracts on requires + [transformed-body (begin0 (change-contract-fixups #'transformed-body) (do-time "Fixed contract ids"))] + ;; potentially optimize the code based on the type information + [(optimized-body ...) (maybe-optimize #'transformed-body)] ;; has own call to do-time + ;; add in syntax property on useless expression to draw check-syntax arrows + [check-syntax-help (syntax-property + (syntax-property + #'(void) + 'disappeared-binding (disappeared-bindings-todo)) + 'disappeared-use (disappeared-use-todo))]) + ;; reconstruct the module with the extra code + ;; use the regular %#module-begin from `racket/base' for top-level printing + (arm #`(#%module-begin #,before-code optimized-body ... #,after-code check-syntax-help)))))))])) (define did-I-suggest-:print-type-already? #f) (define :print-type-message " ... [Use (:print-type ) to see more.]") @@ -57,48 +58,49 @@ [(_ . form) (init) (tc-setup - stx #'form 'top-level body2 void tc-toplevel-form 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)))])))])) + stx #'form 'top-level void 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)))]))))])) 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 3cda760f..47b9364e 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 @@ -36,15 +36,9 @@ (type-alias-env-map (lambda (id ty) (cons (syntax-e id) ty)))))) -(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker pre-result post-result . body) - (tc-setup/proc orig-stx stx expand-ctxt init checker - (λ (fully-expanded-stx pre-result post-result) - . - body))) - (define-logger online-check-syntax) -(define (tc-setup/proc orig-stx stx expand-ctxt init checker f) +(define (tc-setup orig-stx stx expand-ctxt init checker f) (set-box! typed-context? #t) ;(start-timing (syntax-property stx 'enclosing-module-name)) (with-handlers