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

Refactoring.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-20 11:52:11 -04:00
parent 70e1d63bed
commit 4735ad3523
2 changed files with 24 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -42,19 +42,6 @@
;; 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))
@ -72,19 +59,20 @@
[(tc-result1: (== -Void type-equal?)) [(tc-result1: (== -Void type-equal?))
#f] #f]
[(tc-result1: t f o) [(tc-result1: t f o)
(let-values ([(t pruned?) (cleanup-type t)]) ;; Don't display the whole types at the REPL. Some case-lambda types
(format "- : ~a~a\n" t (if pruned? "\nUse :print-type to see more." "")))] ;; are just too large to print.
(let ([tc (cleanup-type t)])
(format "- : ~a~a\n" tc (if (equal? tc t)
""
"\nUse :print-type to see more.")))]
[(tc-results: t) [(tc-results: t)
;; map the first component and ormap the second. (define new-ts (map cleanup-type t))
(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" (format "- : ~a~a\n"
(cons 'Values (reverse ts)) (cons 'Values new-ts)
(if any-pruned? " \nUse :print-type to see more." ""))] ;; did any get pruned?
(if (not (andmap equal? t new-ts))
" \nUse :print-type to see more."
""))]
[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])

12
collects/typed-scheme/typecheck/tc-app-helper.rkt
View File

@ -272,6 +272,18 @@
orig orig
(reverse parts-acc))))))))))) (reverse parts-acc)))))))))))
;; Wrapper over possible-domains that works on types.
(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)))])
res))]
;; not a function type. keep as is.
[_ t]))
(define (poly-fail f-stx args-stx t argtypes #:name [name #f] #:expected [expected #f]) (define (poly-fail f-stx args-stx t argtypes #:name [name #f] #:expected [expected #f])
(match t (match t
[(or (Poly-names: [(or (Poly-names: