From 9f01d26f98cc9b81f0f63c9c7f9ec9ab5282d88a Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Sat, 23 Feb 2013 09:27:34 -0800
Subject: [PATCH] Cleanup kw/opt lambda annotations.

---
 collects/typed-racket/base-env/prims.rkt         | 13 ++++++++++++-
 collects/typed-racket/typecheck/tc-expr-unit.rkt | 10 +++++-----
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt
index 229dd6c81f..f179197d77 100644
--- a/collects/typed-racket/base-env/prims.rkt
+++ b/collects/typed-racket/base-env/prims.rkt
@@ -1051,7 +1051,18 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ formals . body)
      (define d (datum->syntax stx `(,#'λ ,#'formals . ,#'body)
                               stx stx))
-     (syntax-property d 'kw-lambda #t)]))
+     (define-values (has-kw? has-opt?)
+       (syntax-parse #'formals
+        ((~or (~and rest:id (~bind ((args 1) null)))
+              (args ...)
+              (args ...+ . rest:id))
+         (define arg-list (syntax->list #'(args ...)))
+         (values
+           (ormap keyword? (map syntax-e arg-list))
+           (ormap syntax->list arg-list)))))
+      (syntax-property
+        (syntax-property d 'kw-lambda has-kw?)
+        'opt-lambda has-opt?)]))
 
 ;; do this ourselves so that we don't get the static bindings,
 ;; which are harder to typecheck
diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt
index 2a30d0c0e0..148bcd4530 100644
--- a/collects/typed-racket/typecheck/tc-expr-unit.rkt
+++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt
@@ -376,15 +376,15 @@
              (let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _))))
                (#%plain-app _ _ args ...))))
          (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
-        ;; kw function def
+        ;; kw/opt function def
         [(let-values ([(_) fun])
            . body)
-         #:when (syntax-property form 'kw-lambda)
+         #:when (or (syntax-property form 'kw-lambda)
+                    (syntax-property form 'opt-lambda))
          (match expected
-           [(tc-result1: (and f (Function: _))) 
+           [(tc-result1: (and f (or (Function: _)
+                                    (Poly: _ (Function: _)))))
             (tc-expr/check/type #'fun (kw-convert f #:split #t))]
-           [(tc-result1: (Poly-names: names (and f (Function: _))))
-            (tc-expr/check/type #'fun (make-Poly names (kw-convert f #:split #t)))]
            [(tc-result1: _) (tc-error/expr "Keyword functions must have function type, given ~a" expected)])
          expected]
         ;; let