Make tc-setup just take a function instead of 3 identifiers.
original commit: f6ef86d7db520b5ebcfea694c135e525164d37e6
This commit is contained in:
Eric Dobson
parent
b5755371fd
commit
c8c5c12ae2
|
|
@ -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)])))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <expr>) 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)))]))))]))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user