From f4eec91021e7ba0df5b8df8cef87a6bd361d5151 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 4 Sep 2008 17:02:33 -0400
Subject: [PATCH] New representation that accomodates mandatory and optional
 keyword args.

original commit: 79e3a0c4c68070d6a558a006d70c326f4ee2d28a
---
 collects/typed-scheme/private/base-env.ss    |  2 +-
 collects/typed-scheme/private/tc-app-unit.ss |  9 +++++----
 collects/typed-scheme/private/type-rep.ss    | 16 ++++++++++++----
 3 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index 7f1ba924..4c728c58 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -556,7 +556,7 @@
      [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)))]
+     [foo (make-Function (list (make-arr (list N) B #f #f (list (make-Keyword '#:bar B #f)) null null)))]
      )
 
 (begin-for-syntax 
diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss
index 06b372ab..ac5347ef 100644
--- a/collects/typed-scheme/private/tc-app-unit.ss
+++ b/collects/typed-scheme/private/tc-app-unit.ss
@@ -569,12 +569,13 @@
 
 (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)) ...) _ _))
+    [(list (arr: dom rng rest #f (list (and ktys (Keyword: formal-kws formal-kw-tys (and #f required?))) ...) _ _))
      (for ([k kws]
            [ty (map tc-expr/t (syntax->list kw-args))])
-       (cond [(assq k ktys)
+       (cond [(for/or ([e ktys])
+               (and (eq? (Keyword-kw e) k) e))
               =>
-              (match-lambda [(cons k kty)
+              (match-lambda [(Keyword: k kty req?)
                              (unless (subtype ty kty)
                                (tc-error/delayed 
                                 #:stx form
@@ -583,7 +584,7 @@
              [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)]
+     (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)]
     [_ (int-err "case-lambda w/ keywords not supported")]))
 
 
diff --git a/collects/typed-scheme/private/type-rep.ss b/collects/typed-scheme/private/type-rep.ss
index df51d4c8..c63a2a8f 100644
--- a/collects/typed-scheme/private/type-rep.ss
+++ b/collects/typed-scheme/private/type-rep.ss
@@ -90,18 +90,26 @@
                          pred-id
                          cert)])
 
+;; kw : keyword?
+;; ty : Type
+;; required? : Boolean
+(dt Keyword (kw ty required?)
+    [#:frees (free-vars* ty)
+             (free-idxs* ty)]
+    [#:fold-rhs (*Keyword kw (type-rec-id ty))])
+
 ;; dom : Listof[Type]
 ;; rng : Type
 ;; rest : Option[Type]
 ;; drest : Option[Cons[Type,Name or nat]]
-;; kws : Listof[Cons[Kw, Type]]
+;; kws : Listof[Keyword]
 ;; rest and drest NOT both true
 ;; thn-eff : Effect
 ;; els-eff : Effect
 ;; arr is NOT a Type
 (dt arr (dom rng rest drest kws thn-eff els-eff)
     [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null)
-                                                                                (map cdr kws)
+                                                                                (map Keyword-ty kws)
                                                                                 dom)))
                                     (match drest
                                       [(cons t (? symbol? bnd))
@@ -112,7 +120,7 @@
                                     (map make-invariant
                                          (map free-vars* (append thn-eff els-eff)))))
              (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null)
-                                                                                (map cdr kws)
+                                                                                (map Keyword-ty kws)
                                                                                 dom)))
                                     (match drest
                                       [(cons t (? number? bnd))
@@ -127,7 +135,7 @@
                       (and rest (type-rec-id rest))
                       (and drest (cons (type-rec-id (car drest)) (cdr drest)))
                       (for/list ([kw kws])
-                        (cons (car kw) (type-rec-id (cdr kw))))
+                        (cons (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw)))
                       (map effect-rec-id thn-eff)
                       (map effect-rec-id els-eff))])