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

Add tc-toplevel/full and tc-module/full and use them.

Browse Source
This commit is contained in:
Eric Dobson 2013-12-15 10:32:31 -08:00
parent a9e8324a38
commit feeb6c9163
4 changed files with 99 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt
View File

@ -77,14 +77,14 @@
(define (:print-type-impl stx) (define (:print-type-impl stx)
(syntax-parse stx (syntax-parse stx
[(_ e) [(_ e)
(tc-setup stx #'e 'top-level tc-toplevel-form (tc-toplevel/full stx #'e
(lambda (expanded before type) (λ (expanded type)
#`(display #`(display
#,(parameterize ([print-multi-line-case-> #t]) #,(parameterize ([print-multi-line-case-> #t])
(format "~a\n" (match type (format "~a\n" (match type
[(tc-result1: t f o) t] [(tc-result1: t f o) t]
[(tc-results: t) (-values t)] [(tc-results: t) (-values t)]
[(tc-any-results:) ManyUniv]))))))] [(tc-any-results:) ManyUniv]))))))]
[form [form
(raise-syntax-error #f "must be applied to exactly one argument" #'form)])) (raise-syntax-error #f "must be applied to exactly one argument" #'form)]))
@ -93,17 +93,17 @@
(syntax-parse stx (syntax-parse stx
[(_ op arg-type ...) [(_ op arg-type ...)
(with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
(tc-setup stx (tc-toplevel/full
;; create a dummy function with the right argument types stx
#`(lambda #,(stx-map type-label-property ;; create a dummy function with the right argument types
#'(dummy-arg ...) #'(arg-type ...)) #`(lambda #,(stx-map type-label-property
(op dummy-arg ...)) #'(dummy-arg ...) #'(arg-type ...))
'top-level tc-toplevel-form (op dummy-arg ...))
(lambda (expanded before type) (λ (expanded type)
#`(display #`(display
#,(format "~a\n" #,(format "~a\n"
(match type (match type
[(tc-result1: (and t (Function: _)) f o) t]))))))] [(tc-result1: (and t (Function: _)) f o) t]))))))]
[form [form
(raise-syntax-error #f "must be applied to at least one argument" #'form)])) (raise-syntax-error #f "must be applied to at least one argument" #'form)]))
@ -112,17 +112,17 @@
(syntax-parse stx (syntax-parse stx
[(_ op desired-type) [(_ op desired-type)
(let ([expected (parse-type #'desired-type)]) (let ([expected (parse-type #'desired-type)])
(tc-setup stx #'op 'top-level tc-toplevel-form (tc-toplevel/full stx #'op
(lambda (expanded before type) (λ (expanded type)
(match type (match type
[(tc-result1: (and t (Function: _)) f o) [(tc-result1: (and t (Function: _)) f o)
(let ([cleaned (cleanup-type t expected)]) (let ([cleaned (cleanup-type t expected)])
#`(display #`(display
#,(match cleaned #,(match cleaned
[(Function: '()) [(Function: '())
"Desired return type not in the given function's range.\n"] "Desired return type not in the given function's range.\n"]
[(Function: arrs) [(Function: arrs)
(format "~a\n" cleaned)])))] (format "~a\n" cleaned)])))]
[_ (error (format "~a: not a function" (syntax->datum #'op)))]))))] [_ (error (format "~a: not a function" (syntax->datum #'op)))]))))]
[form [form
(raise-syntax-error #f "must be applied to exactly two arguments" #'form)]))) (raise-syntax-error #f "must be applied to exactly two arguments" #'form)])))

96
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt
View File

@ -24,8 +24,7 @@
(let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))])
(parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?)) (parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?))
(and (attribute opt?) (syntax-e (attribute opt?))))]) (and (attribute opt?) (syntax-e (attribute opt?))))])
(tc-setup (tc-module/full stx pmb-form
stx pmb-form 'module-begin tc-module
(λ (new-mod before-code after-code) (λ (new-mod before-code after-code)
(with-syntax* (with-syntax*
(;; pmb = #%plain-module-begin (;; pmb = #%plain-module-begin
@ -61,50 +60,49 @@
;; TODO(endobson): Remove the call to do-standard-inits when it is no longer necessary ;; 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 ;; Cast at the top-level still needs this for some reason
(do-standard-inits) (do-standard-inits)
(tc-setup (tc-toplevel/full stx #'form
stx #'form 'top-level tc-toplevel-form (λ (body2 type)
(λ (body2 before type) (with-syntax*
(with-syntax* ([(optimized-body . _) (maybe-optimize #`(#,body2))])
([(optimized-body . _) (maybe-optimize #`(#,body2))]) (syntax-parse body2
(syntax-parse body2 ;; any of these do not produce an expression to be printed
;; any of these do not produce an expression to be printed [(head:invis-kw . _) (arm #'optimized-body)]
[(head:invis-kw . _) (arm #'optimized-body)] [_ (let ([ty-str (match type
[_ (let ([ty-str (match type ;; don't print results of type void
;; don't print results of type void [(tc-result1: (== -Void type-equal?))
[(tc-result1: (== -Void type-equal?)) #f]
#f] ;; don't print results of unknown type
;; don't print results of unknown type [(tc-any-results:)
[(tc-any-results:) #f]
#f] [(tc-result1: t f o)
[(tc-result1: t f o) ;; Don't display the whole types at the REPL. Some case-lambda types
;; Don't display the whole types at the REPL. Some case-lambda types ;; are just too large to print.
;; are just too large to print. ;; Also, to avoid showing too precise types, we generalize types
;; Also, to avoid showing too precise types, we generalize types ;; before printing them.
;; before printing them. (define tc (cleanup-type t))
(define tc (cleanup-type t)) (define tg (generalize tc))
(define tg (generalize tc)) (format "- : ~a~a~a\n"
(format "- : ~a~a~a\n" tg
tg (cond [(equal? tc tg) ""]
(cond [(equal? tc tg) ""] [else (format " [more precisely: ~a]" tc)])
[else (format " [more precisely: ~a]" tc)]) (cond [(equal? tc t) ""]
(cond [(equal? tc t) ""] [did-I-suggest-:print-type-already? " ..."]
[did-I-suggest-:print-type-already? " ..."] [else (set! did-I-suggest-:print-type-already? #t)
[else (set! did-I-suggest-:print-type-already? #t) :print-type-message]))]
:print-type-message]))] [(tc-results: t)
[(tc-results: t) (define tcs (map cleanup-type t))
(define tcs (map cleanup-type t)) (define tgs (map generalize tcs))
(define tgs (map generalize tcs)) (format "- : ~a~a~a\n"
(format "- : ~a~a~a\n" (cons 'Values tgs)
(cons 'Values tgs) (cond [(andmap equal? tgs tcs) ""]
(cond [(andmap equal? tgs tcs) ""] [else (format " [more precisely: ~a]" (cons 'Values tcs))])
[else (format " [more precisely: ~a]" (cons 'Values tcs))]) ;; did any get pruned?
;; did any get pruned? (cond [(andmap equal? t tcs) ""]
(cond [(andmap equal? t tcs) ""] [did-I-suggest-:print-type-already? " ..."]
[did-I-suggest-:print-type-already? " ..."] [else (set! did-I-suggest-:print-type-already? #t)
[else (set! did-I-suggest-:print-type-already? #t) :print-type-message]))]
:print-type-message]))] [x (int-err "bad type result: ~a" x)])])
[x (int-err "bad type result: ~a" x)])]) (if ty-str
(if ty-str #`(let ([type '#,ty-str])
#`(let ([type '#,ty-str]) (begin0 #,(arm #'optimized-body) (display type)))
(begin0 #,(arm #'optimized-body) (display type))) (arm #'optimized-body)))]))))]))
(arm #'optimized-body)))]))))]))

20
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt
View File

@ -9,8 +9,11 @@
(for-syntax racket/base) (for-syntax racket/base)
(for-template racket/base)) (for-template racket/base))
(lazy-require [typed-racket/optimizer/optimizer (optimize-top)]) (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 (define-syntax-class invis-kw
#:literals (define-values define-syntaxes #%require #:literals (define-values define-syntaxes #%require
@ -39,7 +42,7 @@
(define-logger online-check-syntax) (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) (set-box! typed-context? #t)
;(start-timing (syntax-property stx 'enclosing-module-name)) ;(start-timing (syntax-property stx 'enclosing-module-name))
(with-handlers (with-handlers
@ -73,6 +76,13 @@
(parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)] (parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)]
[expanded-module-stx fully-expanded-stx]) [expanded-module-stx fully-expanded-stx])
(do-time "Starting `checker'") (do-time "Starting `checker'")
(define-values (pre-result post-result) (checker fully-expanded-stx)) (call-with-values (λ () (checker fully-expanded-stx))
(do-time "Typechecking Done") (λ results
(f fully-expanded-stx pre-result post-result))))) (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))

14
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -22,7 +22,7 @@
(provide/cond-contract (provide/cond-contract
[tc-module (syntax? . c:-> . (values syntax? syntax?))] [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)) (define unann-defs (make-free-id-table))
@ -359,18 +359,16 @@
;; typecheck a top-level form ;; typecheck a top-level form
;; used only from #%top-interaction ;; 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) (define (tc-toplevel-form form)
(syntax-parse form (syntax-parse form
;; Don't open up `begin`s that are supposed to be ignored ;; Don't open up `begin`s that are supposed to be ignored
[(~and ((~literal begin) e ...) [(~and ((~literal begin) e ...)
(~not (~or _:ignore^ _:ignore-some^))) (~not (~or _:ignore^ _:ignore-some^)))
(define result (begin0
(for/last ([form (in-syntax #'(e ...))]) (for/last ([form (in-syntax #'(e ...))])
(define-values (_ result) (tc-toplevel-form form)) (tc-toplevel-form form))
result)) (report-all-errors))]
(begin0 (values #f result)
(report-all-errors))]
[_ [_
;; Handle type aliases ;; Handle type aliases
(when (type-alias? form) (when (type-alias? form)
@ -386,6 +384,6 @@
(refine-struct-variance! (list parsed)) (refine-struct-variance! (list parsed))
(register-parsed-struct-bindings! parsed)) (register-parsed-struct-bindings! parsed))
(tc-toplevel/pass1 form) (tc-toplevel/pass1 form)
(begin0 (values #f (tc-toplevel/pass2 form)) (begin0 (tc-toplevel/pass2 form)
(report-all-errors))])) (report-all-errors))]))