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

Handle type ascription and type instantiation better with expected type.

Browse Source 
Add remove-ascription
Identify incorrect element of wrongly typed list.
Use function argument types as expected types.
Allow multiple uses of orig-module-stx, older one takes precedence.

svn: r15857

original commit: b3dde2ca7f0e343e207deb2d983785a7fea64a1b
This commit is contained in:
Sam Tobin-Hochstadt 2009-09-01 22:25:35 +00:00
parent d4b5a51fce
commit c315e83375
4 changed files with 70 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/private/type-annotation.ss
View File

@ -16,6 +16,7 @@
type-ascrip-symbol
type-dotted-symbol
type-ascription
remove-ascription
check-type
dotted?)
@ -65,6 +66,9 @@
[(syntax-property stx type-ascrip-symbol) => pt]
[else #f]))
(define (remove-ascription stx)
(syntax-property stx type-ascrip-symbol #f))
(define (log/ann stx ty)
(printf/log "Required Annotated Variable: ~a ~a~n" (syntax-e stx) ty))
(define (log/extra stx ty ty2)

45
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -462,8 +462,28 @@
(ret (-Promise (tc-expr/t #'e)))]
;; special case for `list'
[(#%plain-app list . args)
(let ([tys (map tc-expr/t (syntax->list #'args))])
(ret (apply -lst* tys)))]
(begin
;(printf "calling list: ~a ~a~n" (syntax->datum #'args) (Type? expected))
(match expected
[(tc-result1: (Mu: var (Union: (or
(list (Pair: elem-ty (F: var)) (Value: '()))
(list (Value: '()) (Pair: elem-ty (F: var)))))))
;(printf "special case 1 ~a~n" elem-ty)
(for ([i (in-list (syntax->list #'args))])
(tc-expr/check i (ret elem-ty)))
expected]
[(tc-result1: (app untuple (? (lambda (ts) (and ts (= (length (syntax->list #'args))
(length ts))))
ts)))
;(printf "special case 2 ~a~n" ts)
(for ([ac (in-list (syntax->list #'args))]
[exp (in-list ts)])
(tc-expr/check ac (ret exp)))
expected]
[_
;(printf "not special case~n")
(let ([tys (map tc-expr/t (syntax->list #'args))])
(ret (apply -lst* tys)))]))]
;; special case for `list*'
[(#%plain-app list* . args)
(match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))]
@ -490,9 +510,24 @@
#'(let-values ([(x) fixed-args] ... [(rst) varg]) . body)
expected)))]
[(#%plain-app f . args)
(let* ([f-ty (single-value #'f)]
[arg-tys (map single-value (syntax->list #'args))])
(tc/funapp #'f #'args f-ty arg-tys expected))]))
(let* ([f-ty (single-value #'f)])
(match f-ty
[(tc-result1:
(and t (Function:
(list (and a (arr: (? (lambda (d)
(= (length d)
(length (syntax->list #'args))))
dom)
(Values: (list (Result: v (LFilterSet: '() '()) (LEmpty:))))
#f #f '()))))))
;(printf "f dom: ~a ~a~n" (syntax->datum #'f) dom)
(let ([arg-tys (map (lambda (a t) (tc-expr/check a (ret t)))
(syntax->list #'args)
dom)])
(tc/funapp #'f #'args f-ty arg-tys expected))]
[_
(let ([arg-tys (map single-value (syntax->list #'args))])
(tc/funapp #'f #'args f-ty arg-tys expected))]))]))
;(trace tc/app/internal)

36
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -68,7 +68,7 @@
([inst (in-improper-stx inst)])
(cond [(not inst) ty]
[(not (or (Poly? ty) (PolyDots? ty)))
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
[(and (Poly? ty)
(not (= (length (syntax->list inst)) (Poly-n ty))))
(tc-error/expr #:return (Un)
@ -199,20 +199,34 @@
(define (tc-expr/check form expected)
(parameterize ([current-orig-stx form])
;(printf "form: ~a~n" (syntax->datum form))
;; the argument must be syntax
(unless (syntax? form)
(int-err "bad form input to tc-expr: ~a" form))
;; typecheck form
(let ([ty (cond [(type-ascription form) => (lambda (ann)
(let ([r (tc-expr/check/internal form ann)])
(check-below r expected)))]
[else (tc-expr/check/internal form expected)])])
(match ty
[(tc-results: ts fs os)
(let ([ts* (do-inst form ts)])
(ret ts* fs os))]
[_ ty]))))
(let loop ([form form] [expected expected] [checked? #f])
(cond [(type-ascription form)
=>
(lambda (ann)
(let* ([r (tc-expr/check/internal form ann)]
[r* (check-below r expected)])
;; around again in case there is an instantiation
;; remove the ascription so we don't loop infinitely
(loop (remove-ascription form) r* #t)))]
[(syntax-property form 'type-inst)
;; check without property first
;; to get the appropriate type to instantiate
(match (tc-expr (syntax-property form 'type-inst #f))
[(tc-results: ts fs os)
;; do the instantiation on the old type
(let* ([ts* (do-inst form ts)]
[ts** (ret ts* fs os)])
;; make sure the new type is ok
(check-below ts** expected))]
;; no annotations possible on dotted results
[ty ty])]
;; nothing to see here
[checked? expected]
[else (tc-expr/check/internal form expected)]))))
;; tc-expr/check : syntax tc-results -> tc-results
(define (tc-expr/check/internal form expected)

2
collects/typed-scheme/typed-scheme.ss
View File

@ -78,7 +78,7 @@
null)])]
[with-syntax ([(pmb body2 ...) #'new-mod])]
[begin (do-time "Local Expand Done")]
[with-syntax ([after-code (parameterize ([orig-module-stx stx]
[with-syntax ([after-code (parameterize ([orig-module-stx (or (orig-module-stx) stx)]
[expanded-module-stx #'new-mod])
(type-check #'(body2 ...)))]
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]