From 30cd701cf0875cf16d5e114d97e5004ca243681e Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 21 Nov 2013 18:27:51 -0500
Subject: [PATCH] Make typed case-lambda methods work

---
 .../typecheck/check-class-unit.rkt            | 16 ++++++++++++-
 .../typed-racket/unit-tests/class-tests.rkt   | 23 +++++++++++++++++++
 2 files changed, 38 insertions(+), 1 deletion(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
index 96269b4bf6..e40feb4953 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
@@ -9,6 +9,7 @@
          racket/match
          racket/pretty ;; DEBUG ONLY
          racket/set
+         racket/syntax
          syntax/parse
          "signatures.rkt"
          "tc-metafunctions.rkt"
@@ -1280,7 +1281,7 @@
 ;; the let-values binding for tc-expr
 (define (annotate-method stx self-type method-type)
   (syntax-parse stx
-    #:literals (let-values #%plain-lambda)
+    #:literals (let-values #%plain-lambda case-lambda)
     [(let-values ([(meth-name:id)
                    (#%plain-lambda (self-param:id id:id ...)
                      body ...)])
@@ -1310,6 +1311,19 @@
                             method-body ...)
                         #t)])
          m)]
+    ;; case-lambda methods
+    [(let-values ([(meth-name:id)
+                   (case-lambda
+                     [(self x ...) body] ...)])
+       m)
+     (define annotated-self-params
+       (for/list ([self-param (in-list (syntax->list #'(self ...)))])
+         (type-ascription-property self-param self-type)))
+     (define/with-syntax (annotated-self ...) annotated-self-params)
+     #`(let-values ([(#,(syntax-property #'meth-name 'type-label method-type))
+                     (case-lambda
+                       [(annotated-self x ...) body] ...)])
+         m)]
     [_ (tc-error "annotate-method: internal error")]))
 
 ;; Set<Symbol> Set<Symbol> String -> Void
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
index 0c4aceef97..87ad98f2ce 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
@@ -1230,4 +1230,27 @@
                           (init-rest [rst : (List Symbol)])))
              (make-object c% "wrong"))
            #:msg #rx"expected: Symbol.*given: String"]
+   ;; check that case-lambda methods work
+   [tc-e (let ()
+           (class object%
+             (super-new)
+             (field [y : Integer 0])
+             (: m (case-> (Any -> Integer)))
+             (public m)
+             (define m (case-lambda [(x) y])))
+           (define c%
+             (class object%
+               (super-new)
+               (: m (case-> (Any -> Void)))
+               (public m)
+               (define m (case-lambda [(x) (void)]))))
+           (send (new c%) m 'anything))
+         -Void]
+   ;; fails, test that case-lambda bodies are checked
+   [tc-err (class object%
+             (super-new)
+             (: m (case-> (Any -> Integer)))
+             (public m)
+             (define m (case-lambda [(x) "bad"])))
+           #:msg #rx"expected: Integer.*given: String"]
    ))