From 654d7e2f4683f65ba7d0a12491d4b3b834bd70f3 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 19 Jun 2008 19:14:32 -0400 Subject: [PATCH] * Add the ability to substitute in starred types for dotted when we've inferred it. * Try and consolidate a lot of the error printing with domain mismatches. --- collects/typed-scheme/private/tc-app-unit.ss | 164 +++++++------------ collects/typed-scheme/private/type-utils.ss | 16 +- 2 files changed, 70 insertions(+), 110 deletions(-) diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index e1091d655a..3122173d1e 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -120,6 +120,27 @@ ;(trace tc-args) +(define (stringify-domain dom rst drst) + (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))]) + (cond [drst + (format "~a~a ... ~a" doms-string (car drst) (cdr drst))] + [rst + (format "~a~a *" doms-string rst)] + [else (stringify dom)]))) + +(define (domain-mismatches ty doms rests drests arg-tys tail-ty tail-bound) + (cond + [(null? doms) + (int-err "How could doms be null: ~a ~a" ty)] + [(= 1 (length doms)) + (format "Domain: ~a~nArguments: ~a~n" + (stringify-domain (car doms) (car rests) (car drests)) + (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))] + [else + (format "Domains:~nArguments: ~a~n" + (stringify (map stringify-domain doms rests drests) "~n~t") + (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))])) + (define (tc/apply f args) (define f-ty (tc-expr f)) ;; produces the first n-1 elements of the list, and the last element @@ -128,80 +149,8 @@ (if (null? (cdr l)) (values (reverse acc) (car l)) (loop (cdr l) (cons (car l) acc))))) - (define (printable-h dom r-ty r-bound) - (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))]) - (cond [r-bound - (format "~a~a ... ~a" doms-string r-ty r-bound)] - [r-ty - (format "~a~a *" doms-string r-ty)] - [else (stringify dom)]))) - (define (printable dom rst drst) - (cond [rst (printable-h dom rst #f)] - [drst (printable-h dom (car drst) (cdr drst))] - [else (printable-h dom #f #f)])) (define-values (fixed-args tail) (split (syntax->list args))) - (define (apply-error doms rests drests arg-tys tail-ty tail-bound) - (if (and (not (null? doms)) (null? (cdr doms))) - (tc-error/expr - #:return (ret (Un)) - (string-append - "bad arguments to apply~n - function expected ~a as fixed arguments and ~a as a rest argument,~n" - " - given ~a as fixed arguments and ~a as a rest argument~n") - (if (null? (car doms)) - "nothing" - (stringify (car doms))) - (cond [(car rests) - (format "~a *" (car rests))] - [(car drests) - (format "~a ... ~a" (car (car drests)) (cdr (car drests)))] - [else "nothing"]) - (if (null? arg-tys) - "nothing" - (stringify arg-tys)) - (if tail-bound - (format "~a ... ~a" tail-ty tail-bound) - tail-ty)) - (tc-error/expr - #:return (ret (Un)) - "no function domain matched in apply~ndomains were: ~n\t~a~narguments were: \n\t~a\n" - (stringify (map printable doms rests drests) "\n\t") - (stringify (append arg-tys (list (if tail-bound - (string-append tail-ty " ... " tail-bound) - tail-ty))))))) - (define (apply-error/poly doms rests drests arg-tys tail-ty tail-bound) - (cond - [(null? doms) (int-err "how could doms be null: ~a ~a" doms f-ty)] - [(= 1 (length doms)) - (cond - [(car rests) - (tc-error/expr - #:return (ret (Un)) - "polymorphic function domain did not match in apply~ndomain was: ~a~nrest argument was: ~a~narguments were ~a~n" - (car doms) (car rests) (printable-h arg-tys tail-ty tail-bound))] - [(car drests) - (tc-error/expr - #:return (ret (Un)) - "polymorphic function domain did not match in apply~ndomain was: ~a~nrest argument was: ~a ... ~a~narguments were ~a~n" - (car doms) (car (car drests)) (cdr (car drests)) (printable-h arg-tys tail-ty tail-bound))] - [else - (tc-error/expr - #:return (ret (Un)) - "polymorphic function domain did not match in apply~ndomain was: ~a~narguments were ~a~n" - (car doms) (printable-h arg-tys tail-ty tail-bound))])] - [else - (tc-error/expr - #:return (ret (Un)) - "no polymorphic function domain matched in apply~ndomains were: ~a~narguments were ~a~n" - (stringify - (for/list ([dom doms] [rest rests] [drest drests]) - (cond - [rest - (format "~a rest argument: ~a" (stringify dom) rest)] - [drest - (format "~a rest argument: ~a ... ~a" (stringify dom) (car drest) (cdr drest))] - [else (stringify dom)])) - "\n") - (printable-h arg-tys tail-ty tail-bound))])) + (match f-ty [(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...))) (when (null? doms) @@ -213,7 +162,10 @@ (let-values ([(tail-ty tail-bound) (with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) - (apply-error doms rests drests arg-tys tail-ty tail-bound))] + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to function in apply:~n" + (domain-mismatches f-ty doms rests drests arg-tys tail-ty tail-bound))))] [(and (car rests*) (let-values ([(tail-ty tail-bound) (with-handlers ([exn:fail? (lambda _ (values #f #f))]) @@ -250,7 +202,10 @@ (cond [(null? doms*) (match f-ty [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) - (apply-error/poly doms rests drests arg-tys tail-ty tail-bound)])] + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to polymorphic function in apply:~n" + (domain-mismatches f-ty doms rests drests arg-tys tail-ty tail-bound)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) @@ -300,7 +255,10 @@ (cond [(null? doms*) (match f-ty [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) - (apply-error/poly doms rests drests arg-tys tail-ty tail-bound)])] + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to polymorphic function in apply:~n" + (domain-mismatches f-ty doms rests drests arg-tys tail-ty tail-bound)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) @@ -387,7 +345,7 @@ [_ (tc-error/expr #:return (ret (Un)) "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])] - [(tc-result: (Function: (list (arr: doms rngs rests #f latent-thn-effs latent-els-effs) ..1)) thn-eff els-eff) + [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1))) thn-eff els-eff) (if (= 1 (length doms)) (let-values ([(thn-eff els-eff) (tc-args argtypes arg-thn-effs arg-els-effs (car doms) (car rests) @@ -401,16 +359,15 @@ (cond [(null? doms*) (tc-error/expr #:return (ret (Un)) - "no function domain matched - domains were:~n~a~narguments were ~a" - (stringify - (for/list ([d doms] [r rests]) - (format "~a ~a*"(stringify d) r)) - "\n") - argtypes)] + (string-append "No function domains matched in function application:" + (domain-mismatches t doms rests drests argtypes #f #f)))] [(subtypes/varargs argtypes (car doms*) (car rests*)) (ret (car rngs))] [else (loop (cdr doms*) (cdr rngs) (cdr rests*))])))] - [(and rft (tc-result: (or (Poly: vars (Function: (list (arr: doms rngs #f #f thn-effs els-effs) ...))) - (PolyDots: (list vars ... _) (Function: (list (arr: doms rngs #f #f thn-effs els-effs) ...)))))) + [(and rft (tc-result: (and t + (or (Poly: vars + (Function: (list (arr: doms rngs #f #f thn-effs els-effs) ...))) + (PolyDots: (list vars ... _) + (Function: (list (arr: doms rngs #f #f thn-effs els-effs) ...))))))) ;(printf "Typechecking poly app~nftype: ~a~n" ftype) ;(printf "ftype again: ~a~n" ftype) ;(printf "resolved ftype: ~a : ~a~n" (equal? rft ftype) rft) @@ -421,14 +378,17 @@ argtypes) (let loop ([doms* doms] [rngs* rngs]) (cond [(null? doms*) - (match-let ([(tc-result: (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs #f #f _ _) ...)))) ftype]) - (if (= 1 (length doms)) - (tc-error/expr #:return (ret (Un)) - "Polymorphic function could not be applied to arguments:~nExpected: ~a ~nActual: ~a" - (stringify (car msg-doms)) (stringify argtypes)) - (tc-error/expr #:return (ret (Un)) - "no polymorphic function domain matched - possible domains were: ~n~a~narguments were: ~n~a" - (stringify (map stringify msg-doms) "\n") (stringify argtypes))))] + (match t + [(Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))) + (tc-error/expr #:return (ret (Un)) + (string-append "Polymorphic function over ~a could not be applied to arguments:~n" + (domain-mismatches t msg-doms msg-rests msg-drests argtypes #f #f)) + (stringify msg-vars))] + [(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))) + (tc-error/expr #:return (ret (Un)) + (string-append "Polymorphic function over ~a ... could not be applied to arguments:~n" + (domain-mismatches t msg-doms msg-rests msg-drests argtypes #f #f)) + (stringify msg-vars))])] [(and (= (length (car doms*)) (length argtypes)) (infer (fv/list (cons (car rngs*) (car doms*))) argtypes (car doms*) (car rngs*) expected)) @@ -455,8 +415,9 @@ )]|# [else (loop (cdr doms*) (cdr rngs*))]))] ;; polymorphic varargs - [(tc-result: (or (Poly: vars (Function: (list (arr: dom rng rest #f thn-eff els-eff)))) - (PolyDots: (list vars ... _) (Function: (list (arr: dom rng rest #f thn-eff els-eff)))))) + [(tc-result: (and t + (or (Poly: vars (Function: (list (arr: dom rng rest #f thn-eff els-eff)))) + (PolyDots: (list vars ... _) (Function: (list (arr: dom rng rest #f thn-eff els-eff))))))) (for-each (lambda (x) (unless (not (Poly? x)) (tc-error "Polymorphic argument ~a to polymorphic function not allowed" x))) argtypes) @@ -474,8 +435,9 @@ (int-err "Inconsistent substitution - arguments not subtypes")) (ret (subst-all substitution rng)))] [else (tc-error/expr #:return (ret (Un)) - "no polymorphic function domain matched - domain was: ~a rest type was: ~a arguments were ~a" - (stringify dom) rest (stringify argtypes))]))] + (string-append + "No polymorphic function domain matched in function application:~n" + (domain-mismatches t (list dom) (list rest) (list #f) argtypes #f #f)))]))] ;; polymorphic ... type [(tc-result: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) (Function: (list (arr: dom rng #f (cons dty dbound) thn-eff els-eff)))))) @@ -498,9 +460,8 @@ (Function: (list (arr: dom rng #f (cons dty dbound) thn-eff els-eff)))) (tc-error/expr #:return (ret (Un)) (string-append - "no polymorphic function domain matched -~n" - "domain was: ~a ~ndotted rest type was: ~a ... ~a~narguments were ~a") - (stringify dom) dty dbound (stringify argtypes))])]))] + "No polymorphic function domain matched in function application:~n" + (domain-mismatches t (list dom) (list #f) (list (cons dty dbound)) argtypes #f #f)))])]))] [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ...)))) (tc-error/expr #:return (ret (Un)) "polymorphic vararg case-lambda application not yet supported")] [(tc-result: (Poly: vars (Function: (list (arr: doms rngs #f drests thn-effs els-effs) ...)))) @@ -510,7 +471,8 @@ (match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop (ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)]) (ret (apply Un ts)))] - [(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) + [(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) ;(trace tc/funapp) diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index c78ea3eaaf..3eab138211 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -49,9 +49,9 @@ (map (lambda (e) (sub-eff sb e)) els-eff)))]) target)) -;; substitute-dots : Listof[Type] Name Type -> Type -(define (substitute-dots images name target) - (define (sb t) (substitute-dots images name t)) +;; substitute-dots : Listof[Type] Option[type] Name Type -> Type +(define (substitute-dots images rimage name target) + (define (sb t) (substitute-dots images rimage name t)) (if (hash-ref (free-vars* target) name #f) (type-case sb target [#:arr dom rng rest drest thn-eff els-eff @@ -63,7 +63,7 @@ (let ([expanded (sb (car drest))]) (map (lambda (img) (substitute img name expanded)) images))) (sb rng) - #f + rimage #f (map (lambda (e) (sub-eff sb e)) thn-eff) (map (lambda (e) (sub-eff sb e)) els-eff)) @@ -102,10 +102,8 @@ (define (subst-all s t) (for/fold ([t t]) ([e s]) (match e - [(list v (list imgs ...) #f) - (substitute-dots imgs v t)] - [(list v (list ts) starred) - (int-err "subst-all: nyi")] + [(list v (list imgs ...) starred) + (substitute-dots imgs starred v t)] [(list v img) (substitute img v t)]))) @@ -129,7 +127,7 @@ (let* ([fixed-tys (take types (length fixed))] [rest-tys (drop types (length fixed))] [body* (subst-all (map list fixed fixed-tys) body)]) - (substitute-dots rest-tys dotted body*))] + (substitute-dots rest-tys #f dotted body*))] [_ (int-err "instantiate-poly: requires Poly type, got ~a" t)])) (define (instantiate-poly-dotted t types image var)