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

Don't print full function intersection types at the REPL, if possible.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-19 16:33:51 -04:00
parent 754b4df5e8
commit 1a66f60eb4
1 changed files with 29 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/typed-scheme/core.rkt
View File

@ -5,9 +5,9 @@
(for-template racket/base) (for-template racket/base)
(private with-types type-contract) (private with-types type-contract)
(except-in syntax/parse id) (except-in syntax/parse id)
racket/match racket/syntax unstable/match racket/match racket/syntax unstable/match racket/list
(types utils convenience) (types utils convenience)
(typecheck typechecker provide-handling tc-toplevel) (typecheck typechecker provide-handling tc-toplevel tc-app-helper)
(env type-name-env type-alias-env) (env type-name-env type-alias-env)
(r:infer infer) (r:infer infer)
(rep type-rep) (rep type-rep)
@ -42,6 +42,19 @@
;; use the regular %#module-begin from `racket/base' for top-level printing ;; use the regular %#module-begin from `racket/base' for top-level printing
(arm #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))))])) (arm #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))))]))
;; Don't display the whole types at the REPL. Some case-lambda types are just too large to print.
;; Returns the type to be printed, and whether the type was pruned or not.
(define (cleanup-type t)
(match t
;; function type, prune if possible.
[(Function: (list (arr: doms rngs rests drests kws) ...))
(let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs #f)])
(let ([res (make-Function (map make-arr
pdoms rngs rests drests (make-list (length pdoms) null)))])
(values res (not (equal? res t)))))]
;; not a function type. display as is.
[_ (values t #f)]))
(define (ti-core stx) (define (ti-core stx)
(syntax-parse stx (syntax-parse stx
[(_ . ((~datum module) . rest)) [(_ . ((~datum module) . rest))
@ -56,11 +69,22 @@
[(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?)) #f] [(tc-result1: (== -Void type-equal?))
#f]
[(tc-result1: t f o) [(tc-result1: t f o)
(format "- : ~a\n" t)] (let-values ([(t pruned?) (cleanup-type t)])
(format "- : ~a~a\n" t (if pruned? " and more..." "")))]
[(tc-results: t) [(tc-results: t)
(format "- : ~a\n" (cons 'Values t))] ;; map the first component and ormap the second.
(define-values (ts any-pruned?)
(for/fold ([ts '()]
[pruned? #f])
([orig t])
(let-values ([(t new-pruned?) (cleanup-type orig)])
(values (cons t ts) (or pruned? new-pruned?)))))
(format "- : ~a~a\n"
(cons 'Values (reverse ts))
(if any-pruned? " and more...\n" ""))]
[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])