Use `Checker` for `tc_lpat` and `tc_lpats`

1 files changed, 25 insertions, 32 deletions

diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index fed31bf53f..59a9ca1e23 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -89,7 +89,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
                        , pe_ctxt = ctxt
                        , pe_orig = PatOrigin }
 
-       ; tc_lpat pat pat_ty penv thing_inside }
+       ; tc_lpat pat_ty pat penv thing_inside }
 
 -----------------
 tcPats :: HsMatchContext GhcRn
@@ -110,7 +110,7 @@ tcPats :: HsMatchContext GhcRn
 --   4. Check that no existentials escape
 
 tcPats ctxt pats pat_tys thing_inside
-  = tc_lpats penv pats pat_tys thing_inside
+  = tc_lpats pat_tys pats penv thing_inside
   where
     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
 
@@ -119,7 +119,7 @@ tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn
            -> TcM ((LPat GhcTcId, a), TcSigmaType)
 tcInferPat ctxt pat thing_inside
   = tcInfer $ \ exp_ty ->
-    tc_lpat pat exp_ty penv thing_inside
+    tc_lpat exp_ty pat penv thing_inside
  where
     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
 
@@ -136,7 +136,7 @@ tcCheckPat_O :: HsMatchContext GhcRn
              -> TcM a                 -- Checker for body
              -> TcM (LPat GhcTcId, a)
 tcCheckPat_O ctxt orig pat pat_ty thing_inside
-  = tc_lpat pat (mkCheckExpType pat_ty) penv thing_inside
+  = tc_lpat (mkCheckExpType pat_ty) pat penv thing_inside
   where
     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }
 
@@ -322,26 +322,20 @@ tcMultiple tc_pat args penv thing_inside
         ; loop penv args }
 
 --------------------
-tc_lpat :: LPat GhcRn
-        -> ExpSigmaType
-        -> PatEnv
-        -> TcM a
-        -> TcM (LPat GhcTcId, a)
-tc_lpat (L span pat) pat_ty penv thing_inside
+tc_lpat :: ExpSigmaType
+        -> Checker (LPat GhcRn) (LPat GhcTcId)
+tc_lpat pat_ty (L span pat) penv thing_inside
   = setSrcSpan span $
     do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty pat penv)
                                           thing_inside
         ; return (L span pat', res) }
 
-tc_lpats :: PatEnv
-         -> [LPat GhcRn] -> [ExpSigmaType]
-         -> TcM a
-         -> TcM ([LPat GhcTcId], a)
-tc_lpats penv pats tys thing_inside
+tc_lpats :: [ExpSigmaType]
+         -> Checker [LPat GhcRn] [LPat GhcTcId]
+tc_lpats tys pats
   = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )
-    tcMultiple (\(p,t) -> tc_lpat p t)
+    tcMultiple (\(p,t) -> tc_lpat t p)
                 (zipEqual "tc_lpats" pats tys)
-                penv thing_inside
 
 --------------------
 tc_pat  :: ExpSigmaType
@@ -357,16 +351,16 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
         ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
 
   ParPat x pat -> do
-        { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+        { (pat', res) <- tc_lpat pat_ty pat penv thing_inside
         ; return (ParPat x pat', res) }
 
   BangPat x pat -> do
-        { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+        { (pat', res) <- tc_lpat pat_ty pat penv thing_inside
         ; return (BangPat x pat', res) }
 
   LazyPat x pat -> do
         { (pat', (res, pat_ct))
-                <- tc_lpat pat pat_ty (makeLazy penv) $
+                <- tc_lpat pat_ty pat (makeLazy penv) $
                    captureConstraints thing_inside
                 -- Ignore refined penv', revert to penv
 
@@ -388,8 +382,8 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
   AsPat x (L nm_loc name) pat -> do
         { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
         ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
-                         tc_lpat pat (mkCheckExpType $ idType bndr_id)
-                                 penv thing_inside
+                         tc_lpat (mkCheckExpType $ idType bndr_id)
+                                 pat penv thing_inside
             -- NB: if we do inference on:
             --          \ (y@(x::forall a. a->a)) = e
             -- we'll fail.  The as-pattern infers a monotype for 'y', which then
@@ -428,7 +422,7 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
             -- expr_wrap2 :: pat_ty "->" inf_arg_ty
 
          -- Pattern must have inf_res_ty
-        ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside
+        ; (pat', res) <- tc_lpat (mkCheckExpType inf_res_ty) pat penv thing_inside
 
         ; pat_ty <- readExpType pat_ty
         ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
@@ -450,7 +444,7 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
                 -- from an outer scope to mention one of these tyvars in its kind.
         ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
                          tcExtendNameTyVarEnv tv_binds $
-                         tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
+                         tc_lpat (mkCheckExpType inner_ty) pat penv thing_inside
         ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
 
@@ -458,7 +452,7 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
 -- Lists, tuples, arrays
   ListPat Nothing pats -> do
         { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
-        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
+        ; (pats', res) <- tcMultiple (\p -> tc_lpat (mkCheckExpType elt_ty) p)
                                      pats penv thing_inside
         ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPat coi
@@ -471,7 +465,7 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
             <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
                                           SynList $
                  \ [elt_ty] ->
-                 do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
+                 do { (pats', res) <- tcMultiple (\p -> tc_lpat (mkCheckExpType elt_ty) p)
                                                  pats penv thing_inside
                     ; return (pats', res, elt_ty) }
         ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
@@ -488,8 +482,8 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
                      -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
         ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
                                            Boxed   -> arg_tys
-        ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)
-                                   thing_inside
+        ; (pats', res) <- tc_lpats (map mkCheckExpType con_arg_tys)
+                                   pats penv thing_inside
 
         ; dflags <- getDynFlags
 
@@ -516,8 +510,8 @@ tc_pat pat_ty ps_pat penv thing_inside = case ps_pat of
                                                penv pat_ty
         ; -- Drop levity vars, we don't care about them here
           let con_arg_tys = drop arity arg_tys
-        ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
-                                 penv thing_inside
+        ; (pat', res) <- tc_lpat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
+                                 pat penv thing_inside
         ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
                  , res)
@@ -1133,8 +1127,7 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
           -- will generate an error below).
 
 tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc)
-tcConArg (arg_pat, arg_ty) penv thing_inside
-  = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside
+tcConArg (arg_pat, arg_ty) = tc_lpat (mkCheckExpType arg_ty) arg_pat
 
 addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
 -- Instantiate the "stupid theta" of the data con, and throw