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

4 files changed, 17 insertions, 13 deletions

diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index ed30afa893..ad5a3474c0 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -89,14 +89,17 @@ tcProc :: LPat GhcRn -> LHsCmdTop GhcRn         -- proc pat -> expr
        -> ExpRhoType                            -- Expected type of whole proc expression
        -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion)
 
-tcProc pat cmd exp_ty
-  = newArrowScope $
-    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
+tcProc pat cmd@(L _ (HsCmdTop names _)) exp_ty
+  = do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
         ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
         ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
+        -- start with the names as they are used to desugar the proc itself
+        -- See #17423
+        ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names
         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
-        ; (pat', cmd') <- tcCheckPat ProcExpr pat (unrestricted arg_ty) $
-                          tcCmdTop cmd_env cmd (unitTy, res_ty)
+        ; (pat', cmd') <- newArrowScope
+                          $ tcCheckPat ProcExpr pat (unrestricted arg_ty)
+                          $ tcCmdTop cmd_env names' cmd (unitTy, res_ty)
         ; let res_co = mkTcTransCo co
                          (mkTcAppCo co1 (mkTcNomReflCo res_ty))
         ; return (pat', cmd', res_co) }
@@ -115,7 +118,7 @@ type CmdArgType = TcTauType                  -- carg_type, a nested tuple
 
 data CmdEnv
   = CmdEnv {
-        cmd_arr :: TcType -- arrow type constructor, of kind *->*->*
+        cmd_arr :: TcType -- ^ Arrow type constructor, of kind *->*->*
     }
 
 mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
@@ -123,15 +126,15 @@ mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
 
 ---------------------------------------
 tcCmdTop :: CmdEnv
+         -> CmdSyntaxTable GhcTc -- ^ Type-checked Arrow class methods (arr, (>>>), ...)
          -> LHsCmdTop GhcRn
          -> CmdType
          -> TcM (LHsCmdTop GhcTc)
 
-tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
+tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)
   = setSrcSpan loc $
-    do  { cmd'   <- tcCmd env cmd cmd_ty
-        ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
-        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
+    do  { cmd' <- tcCmd env cmd cmd_ty
+        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }
 
 ----------------------------------------
 tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)
@@ -319,12 +322,13 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
 
   where
     tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
-    tc_cmd_arg cmd
+    tc_cmd_arg cmd@(L _ (HsCmdTop names _))
        = do { arr_ty <- newFlexiTyVarTy arrowTyConKind
             ; stk_ty <- newFlexiTyVarTy liftedTypeKind
             ; res_ty <- newFlexiTyVarTy liftedTypeKind
+            ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names
             ; let env' = env { cmd_arr = arr_ty }
-            ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
+            ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
 
 -----------------------------------------------------------------
diff --git a/testsuite/tests/gadt/T17423.hs b/testsuite/tests/arrows/should_compile/T17423.hs
index 35023f0612..35023f0612 100644
--- a/testsuite/tests/gadt/T17423.hs
+++ b/testsuite/tests/arrows/should_compile/T17423.hs
diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T
index 279dd109dd..b47cea0538 100644
--- a/testsuite/tests/arrows/should_compile/all.T
+++ b/testsuite/tests/arrows/should_compile/all.T
@@ -16,3 +16,4 @@ test('T5283', normal, compile, [''])
 test('T5267', expect_broken(5267), compile, [''])
 test('T5022', normalise_fun(normalise_errmsg), compile, [''])
 test('T5333', normal, compile, [''])
+test('T17423', normal, compile, [''])
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, [''])