progress

collects/typed-scheme/private/base-env.ss

@@ -555,6 +555,8 @@
      
      [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
      [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> .  b))]
+  
+     [foo (make-Function (list (make-arr (list N) B #f #f (list (cons '#:bar B)) null null)))]
      )
 
 (begin-for-syntax 

collects/typed-scheme/private/extra-procs.ss

@@ -1,5 +1,5 @@
 #lang scheme/base
-(provide assert call-with-values* values*)
+(provide assert call-with-values* values* foo)
 
 (define (assert v)
   (unless v
@@ -16,3 +16,6 @@
 
 (define call-with-values* call-with-values)
 (define values* values)
+
+(define (foo x #:bar [bar #f])
+  bar)

collects/typed-scheme/private/tc-app-unit.ss

@@ -429,7 +429,8 @@
                              "Wrong number of arguments to parameter - expected 0 or 1, got ~a"
                              (length argtypes))])]
         ;; single clause functions
-        [(tc-result: (and t (Function: (list (arr: dom rng rest #f '() latent-thn-effs latent-els-effs))))
+        ;; FIXME - error on non-optional keywords
+        [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs))))
                      thn-eff els-eff)
          (let-values ([(thn-eff els-eff)
                        (tc-args argtypes arg-thn-effs arg-els-effs dom rest 
@@ -566,6 +567,32 @@
         [(tc-result: t)
          (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)]))))
 
+(define (tc-keywords form arities kws kw-args pos-args expected)
+  (match arities
+    [(list (arr: dom rng rest #f (list (and ktys (cons formal-kws formal-kw-tys)) ...) _ _))
+     (for ([k kws]
+           [ty (map tc-expr/t (syntax->list kw-args))])
+       (cond [(assq k ktys)
+              =>
+              (match-lambda [(cons k kty)
+                             (unless (subtype ty kty)
+                               (tc-error/delayed 
+                                #:stx form
+                                "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" 
+                                kty ty k))])]
+             [else
+              (tc-error/expr #:return (ret (Un))
+                             "function does not accept keyword argument ~a" k)]))
+     (tc/funapp #'form #'form (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)]
+    [_ (int-err "case-lambda w/ keywords not supported")]))
+
+
+(define (type->list t)
+  (match t
+    [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))]
+    [(Value: '()) null]
+    [_ (int-err "bad value in type->list: ~a" t)]))
+
 (define (tc/app/internal form expected)
   (kernel-syntax-case* form #f 
     (values apply not list list* call-with-values do-make-object make-object cons
@@ -622,10 +649,22 @@
         (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])]
     ;; special case for `apply'
     [(#%plain-app apply f . args) (tc/apply #'f #'args)]
+    ;; special case for keywords
+    [(#%plain-app
+      (#%plain-app kpe kws num fn)
+      kw-list
+      (#%plain-app list . kw-arg-list)
+      . pos-args)
+     (eq? (syntax-e #'kpe) 'keyword-procedure-extract)
+     (match (tc-expr #'fn)
+       [(tc-result: (Function: arities)) 
+        (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)]
+       [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)
      (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))
-     (let-loop-check #'form #'lp #'actuals #'args #'body expected)]
+     (let-loop-check form #'lp #'actuals #'args #'body expected)]
     ;; or/andmap of ... argument
     [(#%plain-app or/andmap f arg)
      (and 

collects/typed-scheme/private/tc-expr-unit.ss

@@ -41,7 +41,7 @@
     [(null? v) (-val null)]
     [(symbol? v) (-val v)]
     [(string? v) -String]
-    [(keyword? v) -Keyword]
+    [(keyword? v) (-val v)]
     [(bytes? v) -Bytes]
     [(list? v) (-Tuple (map tc-literal v))]
     [(vector? v) (make-Vector (types-of-literals (vector->list v)))]

collects/typed-scheme/private/tc-utils.ss

@@ -70,7 +70,7 @@
        (unless (null? stxs)
          (raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))]))
 
-(define delay-errors? (make-parameter #t))
+(define delay-errors? (make-parameter #f))
 
 (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest)
   (let ([stx (locate-stx stx*)])

collects/typed-scheme/private/type-effect-convenience.ss

@@ -82,7 +82,8 @@
   (case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))]
                [(dom rng rest) (make-arr dom rng rest #f null (list) (list))]
                [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)]
-               [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]))
+               [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]
+               [(dom rng rest drest kws eff1 eff2) (make-arr dom rng rest drest kws eff1 eff2)]))
 
 (define (make-arr-dots dom rng dty dbound)
   (make-arr* dom rng #f (cons dty dbound) null null))

collects/typed-scheme/typed-scheme.ss

@@ -31,7 +31,7 @@
 (provide (rename-out [module-begin #%module-begin]
                      [top-interaction #%top-interaction]
                      [#%plain-lambda lambda]
-                     [#%plain-app #%app]
+                     [#%app #%app]
                      [require require]))
 
 (define-for-syntax catch-errors? #f)