From 382a771d753469e94ee5fbc897371520809794e3 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 21 Oct 2009 13:30:03 +0000 Subject: [PATCH] Better error message for inference with keywords. Do inference when loop is unannotated, even when argument are. Don't infer for ((lambda when vars are annotated. Make promise contracts work. Fix types of min, max, port->lines, subbytes, bytes-length, bytes, bytes-ref svn: r16397 original commit: a5849fb05af85c586bbd730d220b324018a6673e --- collects/typed-scheme/private/base-env.ss | 21 +++++++++++-------- collects/typed-scheme/private/extra-procs.ss | 8 ++----- .../typed-scheme/typecheck/find-annotation.ss | 3 ++- .../typed-scheme/typecheck/tc-app-helper.ss | 19 +++++++++++++++++ collects/typed-scheme/typecheck/tc-app.ss | 14 +++++++++---- collects/typed-scheme/typecheck/tc-if.ss | 2 +- collects/typed-scheme/types/abbrev.ss | 2 +- 7 files changed, 47 insertions(+), 22 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 954abe91..058f6e35 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -185,8 +185,10 @@ [/ (cl->* (->* (list N) N N))] [+ (cl->* (->* '() -Integer -Integer) (->* '() N N))] [- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N))] -[max (->* (list N) N N)] -[min (->* (list N) N N)] +[max (cl->* (->* (list -Integer) -Integer -Integer) + (->* (list N) N N))] +[min (cl->* (->* (list -Integer) -Integer -Integer) + (->* (list N) N N))] [vector? (make-pred-ty (-vec Univ))] [vector-ref (-poly (a) ((-vec a) N . -> . a))] [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (-vec a)))] @@ -510,11 +512,11 @@ ((-HT a b) -Integer . -> . b))] #;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))] -[bytes (->* (list) N -Bytes)] -[bytes-ref (-> -Bytes N N)] +[bytes (->* (list) -Integer -Bytes)] +[bytes-ref (-> -Bytes -Integer -Integer)] [bytes-append (->* (list -Bytes) -Bytes -Bytes)] -[subbytes (cl-> [(-Bytes N) -Bytes] [(-Bytes N N) -Bytes])] -[bytes-length (-> -Bytes N)] +[subbytes (cl-> [(-Bytes -Integer) -Bytes] [(-Bytes -Integer -Integer) -Bytes])] +[bytes-length (-> -Bytes -Integer)] [read-bytes-line (cl-> [() -Bytes] [(-Input-Port) -Bytes] [(-Input-Port Sym) -Bytes])] @@ -694,9 +696,6 @@ [symbol=? (Sym Sym . -> . B)] [false? (make-pred-ty (-val #f))] -;; scheme/port -[port->lines (-> -Input-Port (-lst -String))] - ;; with-stx.ss [generate-temporaries ((Un (-Syntax Univ) (-lst Univ)) . -> . (-lst (-Syntax Sym)))] [check-duplicate-identifier ((-lst (-Syntax Sym)) . -> . (-opt (-Syntax Sym)))] @@ -706,6 +705,10 @@ [current-continuation-marks (-> -Cont-Mark-Set)] +;; scheme/port +[port->lines (cl->* (-Input-Port . -> . (-lst -String)) + (-> (-lst -String)))] + ;; scheme/path [explode-path (-Pathlike . -> . (-lst (Un -Path (-val 'up) (-val 'same))))] diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index 0c8152b1..19f91a6d 100644 --- a/collects/typed-scheme/private/extra-procs.ss +++ b/collects/typed-scheme/private/extra-procs.ss @@ -1,11 +1,11 @@ #lang scheme/base -(provide assert call-with-values* values* foo) +(provide assert) (define (assert v) (unless v (error "Assertion failed - value was #f")) v) - +#; (define (fold-right f c as . bss) (if (or (null? as) (ormap null? bss)) @@ -14,8 +14,4 @@ (apply fold-right f c (cdr as) (map cdr bss)) (car as) (map car bss)))) -(define call-with-values* call-with-values) -(define values* values) -(define (foo x #:bar [bar #f]) - bar) diff --git a/collects/typed-scheme/typecheck/find-annotation.ss b/collects/typed-scheme/typecheck/find-annotation.ss index c4e53b6d..0c85a81a 100644 --- a/collects/typed-scheme/typecheck/find-annotation.ss +++ b/collects/typed-scheme/typecheck/find-annotation.ss @@ -3,6 +3,7 @@ (require "../utils/utils.ss" syntax/parse scheme/contract (rep type-rep) + (env lexical-env) (private type-annotation) (for-template scheme/base)) @@ -55,7 +56,7 @@ #:with (#%plain-app reverse n:id) #'c.e #:with (v) #'(c.v ...) #:fail-unless (free-identifier=? name #'n) #f - (type-annotation #'v)] + (or (type-annotation #'v) (lookup-type/lexical #'v #:fail (lambda _ #f)))] [_ #f])) (syntax-parse stx #:literals (let-values) diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss index 220b26f8..4598b581 100644 --- a/collects/typed-scheme/typecheck/tc-app-helper.ss +++ b/collects/typed-scheme/typecheck/tc-app-helper.ss @@ -63,6 +63,25 @@ (let ([fcn-string (if name (format "function ~a" (syntax->datum name)) "function")]) + (if (and (andmap null? msg-doms) + (null? argtypes)) + (tc-error/expr #:return (ret (Un)) + (string-append + "Could not infer types for applying polymorphic " + fcn-string + "\n")) + (tc-error/expr #:return (ret (Un)) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:~n" + (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) + (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + "")))))] + [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))) + (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))) + (let ([fcn-string (if name + (format "function with keywords ~a" (syntax->datum name)) + "function with keywords")]) (if (and (andmap null? msg-doms) (null? argtypes)) (tc-error/expr #:return (ret (Un)) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index dadb29ce..0dc4ce84 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -443,12 +443,15 @@ (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] [(tc-result1: (Function: arities)) (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] + [(tc-result1: (Poly: _ (Function: _))) + (tc-error/expr #:return (ret (Un)) + "Inference for polymorphic keyword functions not supported")] [(tc-result1: t) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) #:fail-unless expected #f - #:fail-unless (not (andmap type-annotation (syntax->list #'args))) #f + #:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f #:fail-unless (free-identifier=? #'lp #'lp*) #f (let-loop-check form #'lp #'actuals #'args #'body expected)] ;; special cases for classes @@ -510,7 +513,9 @@ ;; inference for ((lambda [(#%plain-app (#%plain-lambda (x ...) . body) args ...) #:fail-unless (= (length (syntax->list #'(x ...))) - (length (syntax->list #'(args ...)))) #f + (length (syntax->list #'(args ...)))) + #f + #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f (tc/let-values #'((x) ...) #'(args ...) #'body #'(let-values ([(x) args] ...) . body) expected)] @@ -520,7 +525,8 @@ (length (syntax->list #'(args ...)))) #f ;; FIXME - remove this restriction - doesn't work because the annotation ;; on rst is not a normal annotation, may have * or ... - #:fail-unless (not (type-annotation #'rst)) #f + #:fail-when (type-annotation #'rst) #f + #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f (let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) (with-syntax ([(fixed-args ...) fixed-args] [varg #`(#%plain-app list #,@varargs)]) @@ -599,7 +605,7 @@ #:return (or expected (ret (Un))) (string-append "No function domains matched in function application:\n" (domain-mismatches t doms rests drests rngs argtys-t #f #f))))] - ;; polymorphic functions without dotted rest + ;; polymorphic functions without dotted rest, and without mandatory keyword args [((tc-result1: (and t (or (Poly: diff --git a/collects/typed-scheme/typecheck/tc-if.ss b/collects/typed-scheme/typecheck/tc-if.ss index 9a73b8bb..1584e867 100644 --- a/collects/typed-scheme/typecheck/tc-if.ss +++ b/collects/typed-scheme/typecheck/tc-if.ss @@ -12,7 +12,7 @@ (typecheck tc-envops tc-metafunctions) syntax/kerncase mzlib/trace - mzlib/plt-match) + scheme/match) ;; if typechecking (import tc-expr^) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 44425df7..27e9ed6e 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -10,7 +10,7 @@ scheme/promise (prefix-in c: scheme/contract) (for-syntax scheme/base syntax/parse) - (for-template scheme/base scheme/contract scheme/tcp)) + (for-template scheme/base scheme/contract scheme/promise scheme/tcp)) (provide (all-defined-out) (rename-out [make-Listof -lst]))