From ac4ae9ebba653c76edb2bb1f08ec1007427e5333 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 4 Jul 2020 17:40:49 -0500
Subject: [PATCH] adjust ->i to fall back to the slow path to signal the error

because the existing shortcut didn't gave the right message all the
time.

Closes #3286
---
 .../tests/racket/contract/arrow-i.rkt         | 30 ++++++++++++++++---
 .../racket/contract/private/arr-i.rkt         | 15 ++++++----
 2 files changed, 35 insertions(+), 10 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt
index 22d6b38278..4b74596d9e 100644
--- a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt
+++ b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt
@@ -2,7 +2,8 @@
 (require "test-util.rkt")
 
 (parameterize ([current-contract-namespace
-                (make-basic-contract-namespace 'racket/contract/parametric)])
+                (make-basic-contract-namespace 'racket/contract/parametric
+                                               'racket/contract/combinator)])
   (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?))
 
   (test/no-error '(->i ([x integer?]) ([y integer?]) any))
@@ -1821,7 +1822,7 @@
    #t)
 
   (test/spec-passed/result
-   'shortcut-error-message
+   'shortcut-error-message-1
    '(with-handlers ([exn:fail?
                      (λ (x) (define m
                               (regexp-match #rx"expected: ([^\n]*)\n"
@@ -1834,7 +1835,29 @@
                   (λ (y) 1)
                   'pos 'neg)
         1))
-   "(and/c number? (>/c 1))")
+   "a number strictly greater than 1")
+
+  (contract-error-test
+   'shortcut-error-message-2
+   '(let ()
+      (define ctc
+        (make-flat-contract
+         #:first-order (λ (x) #f)
+         #:late-neg-projection
+         (λ (b)
+           (λ (x neg-party)
+             (raise-blame-error
+              b x #:missing-party neg-party
+              "an informative error message")))))
+      ((contract (->i ([x any/c])
+                      [_ (x) ctc])
+                 (λ (x) 42)
+                 'pos 'neg)
+       10))
+    (λ (x)
+      (and (exn:fail:contract:blame? x)
+           (regexp-match? #rx"an informative error message"
+                          (exn-message x)))))
 
   (test/spec-passed/result
    'two-underscores
@@ -1858,5 +1881,4 @@
             55 66))
      list)
    '(1 2 3 4))
-      
   )
diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt
index 844349254c..3f2c07dd73 100644
--- a/racket/collects/racket/contract/private/arr-i.rkt
+++ b/racket/collects/racket/contract/private/arr-i.rkt
@@ -1140,15 +1140,18 @@ evaluted left-to-right.)
             (procedure-arity-includes? orig-ctc 1))
        (if (or indy-blame? (orig-ctc obj))
            obj
-           (raise-predicate-blame-error-failure blame obj neg-party
-                                                (contract-name orig-ctc)))]
+           ;; this will signal the violation
+           (undep-and-apply-the-contract orig-ctc obj blame neg-party chaperone?))]
       [(and indy-blame? (flat-contract? orig-ctc))
        obj]
       [else
-       (define ctc (if chaperone?
-                       (coerce-chaperone-contract '->i orig-ctc)
-                       (coerce-contract '->i orig-ctc)))
-       (((get/build-late-neg-projection ctc) blame) obj neg-party)]))
+       (undep-and-apply-the-contract orig-ctc obj blame neg-party chaperone?)]))
+
+  (define (undep-and-apply-the-contract orig-ctc obj blame neg-party chaperone?)
+    (define ctc (if chaperone?
+                    (coerce-chaperone-contract '->i orig-ctc)
+                    (coerce-contract '->i orig-ctc)))
+    (((get/build-late-neg-projection ctc) blame) obj neg-party))
 
   (define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?)
     (un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?))