From a5849fb05af85c586bbd730d220b324018a6673e 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 --- 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 954abe9164..058f6e357c 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 0c8152b109..19f91a6d5f 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 c4e53b6d3e..0c85a81abd 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 220b26f85f..4598b581a5 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 dadb29ce34..0dc4ce847a 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 9a73b8bbb8..1584e86705 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 44425df7ae..27e9ed6e65 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]))