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)
(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)])))

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 ...))])
(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)))]))))]))

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

@ -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))

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

@ -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))]))