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

@@ -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)]
+[max (cl->* (->* (list -Integer) -Integer -Integer)
-[min (->* (list N) N N)]
+            (->* (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 (->* (list) -Integer -Bytes)]
-[bytes-ref (-> -Bytes N N)]
+[bytes-ref (-> -Bytes -Integer -Integer)]
 [bytes-append (->* (list -Bytes) -Bytes -Bytes)]
-[subbytes (cl-> [(-Bytes N) -Bytes] [(-Bytes N N) -Bytes])]
+[subbytes (cl-> [(-Bytes -Integer) -Bytes] [(-Bytes -Integer -Integer) -Bytes])]
-[bytes-length (-> -Bytes N)]
+[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))))]

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)

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)

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))

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: 

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^)

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]))