From c0bcae41f96d7e145bfbaf6d0ec4ef6bfa2f4f18 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Wed, 6 Nov 2013 21:45:44 -0800
Subject: [PATCH] Make wrong arity messages work again.

Closes PR14138.

original commit: 520c33906ef1a79efadfe5495725952e435c209a
---
 .../typed-racket/typecheck/tc-lambda-unit.rkt | 35 ++++++++++---------
 .../tests/typed-racket/fail/wrong-arity.rkt   |  5 +++
 .../typed-racket/succeed/empty-case-arrow.rkt |  3 ++
 3 files changed, 27 insertions(+), 16 deletions(-)
 create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/wrong-arity.rkt
 create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/empty-case-arrow.rkt

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
index 5cb58460..049ef9a3 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
@@ -342,22 +342,25 @@
               (cons formal+body formals+bodies*)])
            (arities-seen-add arities-seen arity))])))
 
-
-   (apply append
-          (for/list ([fb* (in-list used-formals+bodies)])
-            (match-define (list f* b*) fb*)
-            (match (find-matching-arities f*)
-              [(list)
-               (if (and (= 1 (length used-formals+bodies)) expected-type)
-                   ;; TODO improve error message.
-                   (tc-error/expr #:return (list (lam-result null null (list (generate-temporary) Univ) #f (ret (Un))))
-                                  "Expected a function of type ~a, but got a function with the wrong arity"
-                                  expected-type)
-                   (tc/lambda-clause f* b*))]
-              [(list (arr: argss rets rests drests '()) ...)
-               (for/list ([args (in-list argss)] [ret (in-list rets)] [rest (in-list rests)] [drest (in-list drests)])
-                 (tc/lambda-clause/check
-                  f* b* args (values->tc-results ret (formals->list f*)) rest drest))]))))
+   (if (and
+         (empty? used-formals+bodies)
+         ;; If the empty function is expected, then don't error out
+         (match expected-type
+           [(Function: (list)) #f]
+           [_ #t]))
+       ;; TODO improve error message.
+       (tc-error/expr #:return (list (lam-result null null (list (generate-temporary) Univ) #f (ret (Un))))
+                      "Expected a function of type ~a, but got a function with the wrong arity"
+                      expected-type)
+       (apply append
+              (for/list ([fb* (in-list used-formals+bodies)])
+                (match-define (list f* b*) fb*)
+                (match (find-matching-arities f*)
+                  [(list) (tc/lambda-clause f* b*)]
+                  [(list (arr: argss rets rests drests '()) ...)
+                   (for/list ([args (in-list argss)] [ret (in-list rets)] [rest (in-list rests)] [drest (in-list drests)])
+                     (tc/lambda-clause/check
+                      f* b* args (values->tc-results ret (formals->list f*)) rest drest))])))))
 
 (define (tc/mono-lambda/type formals bodies expected)
   (make-Function (map lam-result->type
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/wrong-arity.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/wrong-arity.rkt
new file mode 100644
index 00000000..f5bb8599
--- /dev/null
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/wrong-arity.rkt
@@ -0,0 +1,5 @@
+#;
+(exn-pred "wrong arity")
+#lang typed/racket
+(: f (Number Number -> Number))
+(define (f x) 0)
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/empty-case-arrow.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/empty-case-arrow.rkt
new file mode 100644
index 00000000..0996ea40
--- /dev/null
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/empty-case-arrow.rkt
@@ -0,0 +1,3 @@
+#lang typed/racket
+(: f (case->))
+(define (f x) 0)