From ded837ce103d67401d214eae522963fb2117eb01 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Mon, 12 Jan 2015 17:51:31 -0500
Subject: [PATCH] Fix tc/send to accept keyword argument methods

Closes PR 14910
---
 .../typed-racket/typecheck/tc-expr-unit.rkt   | 20 +++++++---
 .../typed-racket/typecheck/tc-send.rkt        | 39 +++++++++++++++++--
 typed-racket-test/unit-tests/class-tests.rkt  | 16 ++++++--
 3 files changed, 63 insertions(+), 12 deletions(-)

diff --git a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
index 44039eaf..50ee2d6b 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
@@ -202,15 +202,23 @@
       [(case-lambda [formals . body] ...)
        (tc/lambda form #'(formals ...) #'(body ...) expected)]
       ;; send
-      [(let-values (((_) meth))
-         (let-values (((_) rcvr))
-           (let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _))))
-             (let-values ([_arg-var args] ...)
+      [(let-values ([(_) meth])
+         (let-values ([(rcvr-var) rcvr])
+           (let-values (((meth-var) (~and find-app (#%plain-app find-method/who _ _ _))))
+             (let-values ([(arg-var) args] ...)
                (if wrapped-object-check
                    ignore-this-case
-                   (#%plain-app _ _ _arg-var2 ...))))))
+                   (~and core-app
+                         (~or (#%plain-app _ _ _arg-var2 ...)
+                              (let-values ([(_) _] ...)
+                                (#%plain-app (#%plain-app _ _ _ _ _ _)
+                                             _ _ _ ...)))))))))
        (register-ignored! form)
-       (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
+       (tc/send #'find-app #'core-app
+                #'rcvr-var #'rcvr
+                #'meth-var #'meth
+                #'(arg-var ...) #'(args ...)
+                expected)]
       ;; kw function def
       ;; TODO simplify this case
       [(~and (let-values ([(f) fun]) . body) kw:kw-lambda^)
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-send.rkt b/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
index bc037c74..a221e572 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
@@ -4,15 +4,22 @@
 
 (require "../utils/utils.rkt"
          racket/match syntax/stx
+         syntax/parse
+         (env lexical-env)
          (typecheck signatures tc-funapp tc-metafunctions)
          (types base-abbrev resolve utils type-table)
          (rep type-rep)
-         (utils tc-utils))
+         (utils tc-utils)
+         (for-template racket/base))
 
 (import tc-expr^)
 (export tc-send^)
 
-(define (tc/send form rcvr method args [expected #f])
+(define (tc/send form app
+                 rcvr-var rcvr
+                 method-var method
+                 arg-vars args
+                 [expected #f])
   ;; do-check : Type/c -> tc-results/c
   (define (do-check rcvr-type)
     (match rcvr-type
@@ -28,7 +35,9 @@
                          "method name" s
                          "object type" obj
                          #:return -Bottom)]))
-          (tc/funapp rcvr args ftype (stx-map tc-expr args) expected)]
+          (define vars  (list* rcvr-var method-var (syntax->list arg-vars)))
+          (define types (list* rcvr-type ftype (stx-map tc-expr/t args)))
+          (tc/send-internal vars types app expected)]
          [_ (int-err "non-symbol methods not supported by Typed Racket: ~a"
                      rcvr-type)])]
       ;; union of objects, check pointwise and union the results
@@ -43,3 +52,27 @@
   (define final-ret (do-check (tc-expr/t rcvr)))
   (add-typeof-expr form final-ret)
   final-ret)
+
+;; tc/send-internal : (Listof Id) (Listof Type) Syntax (Option TC-Result)
+;;                    -> TC-Result
+;; Handles typechecking the actual application inside the method send
+;; expansion. Most of the work is done by tc/app via tc-expr.
+(define (tc/send-internal vars types app-stx expected)
+  (syntax-parse app-stx
+    #:literal-sets (kernel-literals)
+    #:literals (list)
+    [(#%plain-app meth obj arg ...)
+     (with-lexical-env/extend-types vars types
+       (tc-expr/check #'(#%plain-app meth arg ...)
+                      expected))]
+    [(let-values ([(arg-var) arg] ...)
+       (#%plain-app (#%plain-app cpce s-kp meth kpe kws num)
+                    kws2 kw-args
+                    obj pos-arg ...))
+     (with-lexical-env/extend-types vars types
+       (tc-expr/check
+        #'(let-values ([(arg-var) arg] ...)
+            (#%plain-app (#%plain-app cpce s-kp meth kpe kws num)
+                         kws2 kw-args
+                         pos-arg ...))
+        expected))]))
diff --git a/typed-racket-test/unit-tests/class-tests.rkt b/typed-racket-test/unit-tests/class-tests.rkt
index 4d614c60..fd8bd8f8 100644
--- a/typed-racket-test/unit-tests/class-tests.rkt
+++ b/typed-racket-test/unit-tests/class-tests.rkt
@@ -730,7 +730,6 @@
              (m "foo"))
            #:ret (ret (-class #:method ([m (t:-> -Integer -Integer)])))]
    ;; test that keyword methods type-check
-   ;; FIXME: send with keywords does not work yet
    [tc-e (let ()
            (: c% (Class [n (Integer #:foo Integer -> Integer)]))
            (define c%
@@ -738,8 +737,19 @@
                (super-new)
                (define/public (n x #:foo foo)
                  (+ foo x))))
-           (void))
-         -Void]
+           (send (new c%) n 0 #:foo 1))
+         -Integer]
+   ;; fails, bad kw argument
+   [tc-err (let ()
+             (: c% (Class [n (Integer #:foo Integer -> Integer)]))
+             (define c%
+               (class object%
+                 (super-new)
+                 (define/public (n x #:foo foo)
+                   (+ foo x))))
+             (send (new c%) n 0 #:foo "foo")
+             (error "foo"))
+           #:msg #rx"expected Integer.*got String"]
    ;; test instance subtyping
    [tc-e (let ()
            (define c%