Arrows: correctly query arrow methods (#17423)

Consider the following code:

    proc (C x y) -> ...

Before this patch, the evidence binding for the Arrow dictionary was
attached to the C pattern:

    proc (C x y) { $dArrow = ... } -> ...

But then when we desugar this, we use arrow operations ("arr", ">>>"...)
specialised for this arrow:

    let
        arr_xy = arr $dArrow -- <-- Not in scope!
        ...
    in
        arr_xy (\(C x y) { $dArrow = ... } -> ...)

This patch allows arrow operations to be type-checked before the proc
itself, avoiding this issue.

Fix #17423

2 files changed, 0 insertions, 38 deletions

diff --git a/testsuite/tests/gadt/T17423.hs b/testsuite/tests/gadt/T17423.hs
deleted file mode 100644
index 35023f0612..0000000000
--- a/testsuite/tests/gadt/T17423.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE Arrows, GADTs #-}
-
-module Main where
-
-import Control.Arrow
-import Control.Category
-import Prelude hiding (id, (.))
-
-data DecoType a where
-   -- | Icons and colours for @False@ and @True@ respectively.
-   DecoBool :: Maybe (String, String) -> Maybe (Int, Int) -> DecoType Bool
-   -- | Icons and colours for ranges within type @a@.
-   DecoRange :: String -> DecoType a
-
--- Sub-dialog for designing decorated booleans.
-decoBoolDialog :: Gadget (DecoType Bool) (DecoType Bool)
-decoBoolDialog =
-      -- arr (\(DecoBool i c) -> (i, c)) >>> (icons *** colours) >>> arr (uncurry DecoBool)
-      proc (DecoBool i c) -> do   -- Compiler panic in GHC 8.6.5.
-         i1 <- id -< i
-         c1 <- id -< c
-         returnA -< DecoBool i1 c1
-
-
-
-data Gadget b c = Pure (b -> c)
-
-instance Category Gadget where
-   id = Pure id
-   Pure g1 . Pure g2 = Pure $ g1 . g2
-
-instance Arrow Gadget where
-   arr = Pure
-   first (Pure f) = Pure $ \(b, b1) -> (f b, b1)
-
-
-main = putStrLn "Hello world."
diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T
index 05ec39f18e..225d8e8650 100644
--- a/testsuite/tests/gadt/all.T
+++ b/testsuite/tests/gadt/all.T
@@ -119,6 +119,5 @@ test('T14808', normal, compile, [''])
 test('T15009', normal, compile, [''])
 test('T15558', normal, compile, [''])
 test('T16427', normal, compile_fail, [''])
-test('T17423', expect_broken(17423), compile_and_run, [''])
 test('T18191', normal, compile_fail, [''])
 test('SynDataRec', normal, compile, [''])