From 6059fb481ba4671f9087de209345641b8be69213 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Wed, 31 Dec 2014 22:36:01 -0500
Subject: [PATCH] Check expected type before calling tc/funapp1

This compensates for a change in commit bb3f446186f
that made the possible-domains function more permissive
(possibly returning results that are inconsistent with the
 expected type).

Closes PR 14889
---
 .../typed-racket/typecheck/tc-app-helper.rkt         | 12 ++++++++++--
 typed-racket-test/unit-tests/typecheck-tests.rkt     |  4 ++++
 2 files changed, 14 insertions(+), 2 deletions(-)

diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
index 0d263cd5..5c330091 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
@@ -4,7 +4,7 @@
          racket/match unstable/list unstable/sequence racket/set racket/list
          (only-in srfi/1 unzip4) (only-in racket/list make-list)
          (contract-req)
-         (typecheck check-below tc-subst)
+         (typecheck check-below tc-subst tc-metafunctions)
          (utils tc-utils)
          (rep type-rep filter-rep)
          (except-in (types utils abbrev subtype)
@@ -158,7 +158,15 @@
                          (values pdoms prngs prests pdrests))])
          ;; only use `tc/funapp1` if `tail-ty` was *not* provided
          ;; since it either won't error correctly or produces a poor error
-         (cond [(and (not tail-ty) (= (length pdoms) 1))
+         (cond [(and (not tail-ty)
+                     (= (length pdoms) 1)
+                     ;; The correctness of selecting this case depends on the
+                     ;; domain selection being consistent with the expected
+                     ;; type. Since possible-domains only checks this in restrictive
+                     ;; mode, do the check here. Note that using restrictive mode
+                     ;; above results in poor error messages (see PR 14731).
+                     (or (not expected)
+                         (subtype (car rngs) (tc-results->values expected))))
                 ;; if we narrowed down the possible cases to a single one, have
                 ;; tc/funapp1 generate a better error message
                 (tc/funapp1 f-stx args-stx
diff --git a/typed-racket-test/unit-tests/typecheck-tests.rkt b/typed-racket-test/unit-tests/typecheck-tests.rkt
index 07e2c067..b28136ed 100644
--- a/typed-racket-test/unit-tests/typecheck-tests.rkt
+++ b/typed-racket-test/unit-tests/typecheck-tests.rkt
@@ -3424,6 +3424,10 @@
                                          (car p))))
                (void))
              -Void]
+
+       ;; PR 14889
+       [tc-err (ann (vector-ref (ann (vector "hi") (Vectorof String)) 0) Symbol)
+               #:msg #rx"Polymorphic function.*could not be applied"]
        )
 
   (test-suite