WIP: Remove NoGhcTc from HsMatchContextwip/remove-noghctc

19 files changed, 113 insertions, 55 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 7798e9c6aa..a808478906 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -185,7 +185,6 @@ data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper
 
 deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)
 
-type instance HsDoRn (GhcPass _) = GhcRn
 type instance HsBracketRn (GhcPass _) = GhcRn
 type instance PendingRnSplice' (GhcPass _) = PendingRnSplice
 type instance PendingTcSplice' (GhcPass _) = PendingTcSplice
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 56fed18520..4016e34405 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -63,6 +63,7 @@ type instance XRec (GhcPass p) a = GenLocated (Anno a) a
 type instance Anno RdrName = SrcSpanAnnN
 type instance Anno Name    = SrcSpanAnnN
 type instance Anno Id      = SrcSpanAnnN
+type instance Anno (CtxIdGhcP p) = SrcSpanAnnN
 
 type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (ApiAnn' a),
                           IsPass p)
@@ -150,15 +151,41 @@ instance IsPass 'Typechecked where
 
 type instance IdP (GhcPass p) = IdGhcP p
 
+type instance CtxIdP (GhcPass p) = CtxIdGhcP p
+
 -- | Maps the "normal" id type for a given GHC pass
 type family IdGhcP pass where
   IdGhcP 'Parsed      = RdrName
   IdGhcP 'Renamed     = Name
   IdGhcP 'Typechecked = Id
 
+data CtxIdGhcP pass where
+  CtxIdName :: Name -> CtxIdGhcP pass
+  CtxIdRdrName :: RdrName -> CtxIdGhcP 'Parsed
+
+instance Typeable pass => Data (CtxIdGhcP pass) where
+  gunfold _ _ _ = panic "instance Data CtxIdGhcP"
+  toConstr  _   = panic "instance Data CtxIdGhcP"
+  dataTypeOf _  = panic "instance Data CtxIdGhcP"
+
+instance Outputable (CtxIdGhcP pass) where
+  ppr (CtxIdName name) = ppr name
+  ppr (CtxIdRdrName name) = ppr name
+
+instance OutputableBndr (CtxIdGhcP pass) where
+  pprBndr b (CtxIdName name) = pprBndr b name
+  pprBndr b (CtxIdRdrName name) = pprBndr b name
+
+  pprInfixOcc (CtxIdName name) = pprInfixOcc name
+  pprInfixOcc (CtxIdRdrName name) = pprInfixOcc name
+
+  pprPrefixOcc (CtxIdName name) = pprPrefixOcc name
+  pprPrefixOcc (CtxIdRdrName name) = pprPrefixOcc name
+
 -- |Constraint type to bundle up the requirement for 'OutputableBndr'
 type OutputableBndrId pass =
   ( OutputableBndr (IdGhcP pass)
+  , Outputable (GenLocated (Anno (CtxIdGhcP pass)) (CtxIdGhcP pass))
   , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass))
   , IsPass pass
   )
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 854e9d25a8..307e8224c9 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -304,11 +304,11 @@ nlParPat p = noLocA (ParPat noAnn p)
 mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs
 mkHsFractional :: FractionalLit -> HsOverLit GhcPs
 mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs
-mkHsDo         :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsDoAnns     :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> ApiAnn' AnnList -> HsExpr GhcPs
-mkHsComp       :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
+mkHsDo         :: HsStmtContext GhcPs -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
+mkHsDoAnns     :: HsStmtContext GhcPs -> LocatedL [ExprLStmt GhcPs] -> ApiAnn' AnnList -> HsExpr GhcPs
+mkHsComp       :: HsStmtContext GhcPs -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
                -> HsExpr GhcPs
-mkHsCompAnns   :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
+mkHsCompAnns   :: HsStmtContext GhcPs -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
                -> ApiAnn' AnnList
                -> HsExpr GhcPs
 
@@ -578,7 +578,7 @@ nlWildPat  = noLocA (WildPat noExtField )
 nlWildPatName :: LPat GhcRn
 nlWildPatName  = noLocA (WildPat noExtField )
 
-nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)]
+nlHsDo :: HsStmtContext GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]
        -> LHsExpr GhcPs
 nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
 
@@ -920,11 +920,11 @@ mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
 mkSimpleGeneratedFunBind loc fun pats expr
   = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)
-              [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
+              [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) (CtxIdRdrName fun))) pats expr
                        emptyLocalBinds]
 
 -- | Make a prefix, non-strict function 'HsMatchContext'
-mkPrefixFunRhs :: LIdP p -> HsMatchContext p
+mkPrefixFunRhs :: XRec p (CtxIdP p) -> HsMatchContext p
 mkPrefixFunRhs n = FunRhs { mc_fun = n
                           , mc_fixity = Prefix
                           , mc_strictness = NoSrcStrict }
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 64114b513f..c55028a5a2 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -159,7 +159,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
                           --            predicate of the coverage checker
                           -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"
                           matchWrapper
-                           (mkPrefixFunRhs (L loc (idName fun)))
+                           (mkPrefixFunRhs (L loc (CtxIdName (idName fun))))
                            Nothing matches
 
         ; core_wrap <- dsHsWrapper co_fn
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index f858736cc1..0381d9d272 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -206,7 +206,7 @@ dsUnliftedBind (FunBind { fun_id = L l fun
                         , fun_tick = tick }) body
                -- Can't be a bang pattern (that looks like a PatBind)
                -- so must be simply unboxed
-  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l (CtxIdName (idName fun))))
                                      Nothing matches
        ; MASSERT( null args ) -- Functions aren't lifted
        ; MASSERT( isIdHsWrapper co_fn )
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 9ac689c4d4..c239ea9497 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -649,7 +649,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
                                                   , m_ctxt = ctxt, m_pats = pats
                                                   , m_grhss = rhs }
                    where
-                     ctxt = FunRhs { mc_fun = ln
+                     ctxt = FunRhs { mc_fun = mapLoc CtxIdRdrName ln
                                    , mc_fixity = Prefix
                                    , mc_strictness = NoSrcStrict }
 
@@ -658,7 +658,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
                                                 , m_pats = [p1, p2]
                                                 , m_grhss = rhs }
                    where
-                     ctxt = FunRhs { mc_fun = ln
+                     ctxt = FunRhs { mc_fun = mapLoc CtxIdRdrName ln
                                    , mc_fixity = Infix
                                    , mc_strictness = NoSrcStrict }
 
@@ -1214,7 +1214,7 @@ checkFunBind strictness locF ann lhs_loc fun is_infix pats (L rhs_span grhss)
         return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)
                  [L match_span (Match { m_ext = ApiAnn (spanAsAnchor locF) ann cs
                                       , m_ctxt = FunRhs
-                                          { mc_fun    = fun
+                                          { mc_fun    = mapLoc CtxIdRdrName fun
                                           , mc_fixity = is_infix
                                           , mc_strictness = strictness }
                                       , m_pats = ps
@@ -1247,7 +1247,7 @@ checkPatBind loc annsIn (L _ (BangPat (ApiAnn _ ans cs) (L _ (VarPat _ v))))
                 [L (noAnnSrcSpan loc) (m (ApiAnn (spanAsAnchor loc) (ans++annsIn) cs) v)]))
   where
     m a v = Match { m_ext = a
-                  , m_ctxt = FunRhs { mc_fun    = v
+                  , m_ctxt = FunRhs { mc_fun    = mapLoc CtxIdRdrName v
                                     , mc_fixity = Prefix
                                     , mc_strictness = SrcStrict }
                   , m_pats = []
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 23f201f120..98347fd155 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -502,7 +502,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name
 
         ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
                                 -- bindSigTyVars tests for LangExt.ScopedTyVars
-                                 rnMatchGroup (mkPrefixFunRhs name)
+                                 rnMatchGroup (mkPrefixFunRhs (mapLoc CtxIdName name))
                                               rnLExpr matches
         ; let is_infix = isInfixFunBind bind
         ; when is_infix $ checkPrecMatch plain_name matches'
@@ -713,7 +713,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
             ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
             ExplicitBidirectional mg ->
                 do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $
-                                   rnMatchGroup (mkPrefixFunRhs (L l name))
+                                   rnMatchGroup (mkPrefixFunRhs (L l (CtxIdName name)))
                                                 rnLExpr mg
                    ; return (ExplicitBidirectional mg', fvs) }
 
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index d61b7180ef..7b9d538f65 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -163,7 +163,7 @@ gen_Functor_binds loc tycon _
     fmap_eqns = [mkSimpleMatch fmap_match_ctxt
                                [nlWildPat]
                                coerce_Expr]
-    fmap_match_ctxt = mkPrefixFunRhs fmap_name
+    fmap_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName fmap_name)
 
 gen_Functor_binds loc tycon tycon_args
   = (listToBag [fmap_bind, replace_bind], emptyBag)
@@ -173,7 +173,7 @@ gen_Functor_binds loc tycon tycon_args
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
     fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
-    fmap_match_ctxt = mkPrefixFunRhs fmap_name
+    fmap_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName fmap_name)
 
     fmap_eqn con = flip evalState bs_RDRs $
                      match_for_con fmap_match_ctxt [f_Pat] con parts
@@ -212,7 +212,7 @@ gen_Functor_binds loc tycon tycon_args
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
     replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
-    replace_match_ctxt = mkPrefixFunRhs replace_name
+    replace_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName replace_name)
 
     replace_eqn con = flip evalState bs_RDRs $
         match_for_con replace_match_ctxt [z_Pat] con parts
@@ -797,7 +797,7 @@ gen_Foldable_binds loc tycon _
     foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
                                   [nlWildPat, nlWildPat]
                                   mempty_Expr]
-    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
+    foldMap_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName foldMap_name)
 
 gen_Foldable_binds loc tycon tycon_args
   | null data_cons  -- There's no real point producing anything but
@@ -840,7 +840,7 @@ gen_Foldable_binds loc tycon tycon_args
       go (NullM a) = Just (Just a)
 
     null_name = L (noAnnSrcSpan loc) null_RDR
-    null_match_ctxt = mkPrefixFunRhs null_name
+    null_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName null_name)
     null_bind = mkRdrFunBind null_name null_eqns
     null_eqns = map null_eqn data_cons
     null_eqn con
@@ -1027,7 +1027,7 @@ gen_Traversable_binds loc tycon _
         [mkSimpleMatch traverse_match_ctxt
                        [nlWildPat, z_Pat]
                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
-    traverse_match_ctxt = mkPrefixFunRhs traverse_name
+    traverse_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName traverse_name)
 
 gen_Traversable_binds loc tycon tycon_args
   = (unitBag traverse_bind, emptyBag)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 5f2f69bee2..93eadc0b8f 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1974,7 +1974,7 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
           --               @(a -> [T x]      -> c -> Int)
           --               op
           mkRdrFunBind loc_meth_RDR [mkSimpleMatch
-                                        (mkPrefixFunRhs loc_meth_RDR)
+                                        (mkPrefixFunRhs (mapLoc CtxIdRdrName loc_meth_RDR))
                                         [] rhs_expr]
         , -- The derived instance signature, e.g.,
           --
@@ -2245,7 +2245,7 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
 mkFunBindSE arity loc fun pats_and_exprs
   = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches
   where
-    matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+    matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) (CtxIdRdrName fun)))
                                (map (parenthesizePat appPrec) p) e
                                emptyLocalBinds
               | (p,e) <-pats_and_exprs]
@@ -2266,7 +2266,7 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName
 mkFunBindEC arity loc fun catch_all pats_and_exprs
   = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches
   where
-    matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+    matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) (CtxIdRdrName fun)))
                                 (map (parenthesizePat appPrec) p) e
                                 emptyLocalBinds
               | (p,e) <- pats_and_exprs ]
@@ -2293,7 +2293,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
    -- which can happen with -XEmptyDataDecls
    -- See #4302
    matches' = if null matches
-              then [mkMatch (mkPrefixFunRhs fun)
+              then [mkMatch (mkPrefixFunRhs (mapLoc CtxIdRdrName fun))
                             (replicate (arity - 1) nlWildPat ++ [z_Pat])
                             (catch_all $ nlHsCase z_Expr [])
                             emptyLocalBinds]
@@ -2313,7 +2313,7 @@ mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
    -- which can happen with -XEmptyDataDecls
    -- See #4302
    matches' = if null matches
-              then [mkMatch (mkPrefixFunRhs fun)
+              then [mkMatch (mkPrefixFunRhs (mapLoc CtxIdRdrName fun))
                             (replicate arity nlWildPat)
                             (error_Expr str) emptyLocalBinds]
               else matches
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 2f62d3d712..b4e57d0093 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -123,7 +123,7 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
              <+> quotes (ppr fun_name) <+> text "have"
     ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True
                          -- But that's wrong for f :: Int -> forall a. blah
-    what   = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
+    what   = FunRhs { mc_fun = mapLoc CtxIdName fn, mc_fixity = Prefix, mc_strictness = strictness }
     match_ctxt = MC { mc_what = what, mc_body = tcBody }
     strictness
       | [L _ match] <- unLoc $ mg_alts matches
@@ -186,12 +186,42 @@ tcGRHSsPat grhss res_ty
 ********************************************************************* -}
 
 data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
-  = MC { mc_what :: HsMatchContext GhcRn,  -- What kind of thing this is
+  = MC { mc_what :: HsMatchContext GhcTc,  -- What kind of thing this is
          mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of
                                            -- an alternative
                  -> ExpRhoType
                  -> TcM (LocatedA (body GhcTc)) }
 
+tcCtxId :: CtxIdP GhcRn -> CtxIdP GhcTc
+tcCtxId (CtxIdName name) = CtxIdName name
+
+tcMatchCtxt :: HsMatchContext GhcRn -> HsMatchContext GhcTc
+tcMatchCtxt ctx = case ctx of
+  FunRhs name fxt stx -> FunRhs (mapLoc tcCtxId name) fxt stx
+  LambdaExpr -> LambdaExpr
+  CaseAlt -> CaseAlt
+  IfAlt -> IfAlt
+  ProcExpr -> ProcExpr
+  PatBindRhs -> PatBindRhs
+  PatBindGuards -> PatBindGuards
+  RecUpd -> RecUpd
+  StmtCtxt sc -> StmtCtxt (tcStmtCtxt sc)
+  ThPatSplice -> ThPatSplice
+  ThPatQuote -> ThPatQuote
+  PatSyn -> PatSyn
+
+tcStmtCtxt :: HsStmtContext GhcRn -> HsStmtContext GhcTc
+tcStmtCtxt ctx = case ctx of
+  ListComp -> ListComp
+  MonadComp -> MonadComp
+  DoExpr mn -> DoExpr mn
+  MDoExpr mn -> MDoExpr mn
+  ArrowExpr -> ArrowExpr
+  GhciStmtCtxt -> GhciStmtCtxt
+  PatGuard mc -> PatGuard (tcMatchCtxt mc)
+  ParStmtCtxt sc -> ParStmtCtxt (tcStmtCtxt sc)
+  TransStmtCtxt sc -> TransStmtCtxt (tcStmtCtxt sc)
+
 type AnnoBody body
   = ( Outputable (body GhcRn)
     , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
@@ -299,7 +329,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs)
 ************************************************************************
 -}
 
-tcDoStmts :: HsStmtContext GhcRn
+tcDoStmts :: HsStmtContext GhcTc
           -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
           -> ExpRhoType
           -> TcM (HsExpr GhcTc)          -- Returns a HsDo
@@ -346,13 +376,13 @@ type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
 type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType
 
 type TcStmtChecker body rho_type
-  =  forall thing. HsStmtContext GhcRn
+  =  forall thing. HsStmtContext GhcTc
                 -> Stmt GhcRn (LocatedA (body GhcRn))
                 -> rho_type                 -- Result type for comprehension
                 -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
                 -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
 
-tcStmts :: (AnnoBody body) => HsStmtContext GhcRn
+tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
         -> TcStmtChecker body rho_type   -- NB: higher-rank type
         -> [LStmt GhcRn (LocatedA (body GhcRn))]
         -> rho_type
@@ -362,7 +392,7 @@ tcStmts ctxt stmt_chk stmts res_ty
                         const (return ())
        ; return stmts' }
 
-tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn
+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
                -> TcStmtChecker body rho_type    -- NB: higher-rank type
                -> [LStmt GhcRn (LocatedA (body GhcRn))]
                -> rho_type
@@ -1000,7 +1030,7 @@ join :: tn -> res_ty
 -}
 
 tcApplicativeStmts
-  :: HsStmtContext GhcRn
+  :: HsStmtContext GhcTc
   -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
   -> ExpRhoType                         -- rhs_ty
   -> (TcRhoType -> TcM t)               -- thing_inside
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index c652ae73da..d2808f9176 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -95,7 +95,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
        ; tc_lpat pat_ty penv pat thing_inside }
 
 -----------------
-tcPats :: HsMatchContext GhcRn
+tcPats :: HsMatchContext GhcTc
        -> [LPat GhcRn]            -- Patterns,
        -> [Scaled ExpSigmaType]         --   and their types
        -> TcM a                  --   and the checker for the body
@@ -117,7 +117,7 @@ tcPats ctxt pats pat_tys thing_inside
   where
     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
 
-tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn
+tcInferPat :: HsMatchContext GhcTc -> LPat GhcRn
            -> TcM a
            -> TcM ((LPat GhcTc, a), TcSigmaType)
 tcInferPat ctxt pat thing_inside
@@ -126,14 +126,14 @@ tcInferPat ctxt pat thing_inside
  where
     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
 
-tcCheckPat :: HsMatchContext GhcRn
+tcCheckPat :: HsMatchContext GhcTc
            -> LPat GhcRn -> Scaled TcSigmaType
            -> TcM a                     -- Checker for body
            -> TcM (LPat GhcTc, a)
 tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin
 
 -- | A variant of 'tcPat' that takes a custom origin
-tcCheckPat_O :: HsMatchContext GhcRn
+tcCheckPat_O :: HsMatchContext GhcTc
              -> CtOrigin              -- ^ origin to use if the type needs inst'ing
              -> LPat GhcRn -> Scaled TcSigmaType
              -> TcM a                 -- Checker for body
@@ -160,7 +160,7 @@ data PatEnv
 
 data PatCtxt
   = LamPat   -- Used for lambdas, case etc
-       (HsMatchContext GhcRn)
+       (HsMatchContext GhcTc)
 
   | LetPat   -- Used only for let(rec) pattern bindings
              -- See Note [Typing patterns in pattern bindings]
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 09edfcb8c3..e67a6608d0 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2231,7 +2231,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
         ; let loc' = noAnnSrcSpan $ locA loc
         ; interPrintName <- getInteractivePrintName
         ; let fresh_it  = itName uniq (locA loc)
-              matches   = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr
+              matches   = [mkMatch (mkPrefixFunRhs (L loc' (CtxIdRdrName fresh_it))) [] rn_expr
                                    emptyLocalBinds]
               -- [it = expr]
               the_bind  = L loc $ (mkTopFunBind FromSource
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index f2b1c87ad6..22a10d5606 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2082,7 +2082,7 @@ mkDefMethBind dfun_id clas sel_id dm_name
                                       , tyConBinderArgFlag tcb /= Inferred ]
               rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
               bind = noLocA $ mkTopFunBind Generated fn $
-                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
+                             [mkSimpleMatch (mkPrefixFunRhs (mapLoc CtxIdName fn)) [] rhs]
 
         ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body"
                    FormatHaskell
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 642429d61b..2b89943b75 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -802,7 +802,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty
                        , mg_origin = Generated
                        }
-             match = mkMatch (mkPrefixFunRhs (L loc name)) []
+             match = mkMatch (mkPrefixFunRhs (L loc (CtxIdName name))) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
                                        req_dicts body')
                              (EmptyLocalBinds noExtField)
@@ -939,7 +939,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
           where
             builder_args  = [L (na2la loc) (VarPat noExtField (L loc n))
                             | L loc n <- args]
-            builder_match = mkMatch (mkPrefixFunRhs ps_lname)
+            builder_match = mkMatch (mkPrefixFunRhs (mapLoc CtxIdName ps_lname))
                                     builder_args body
                                     (EmptyLocalBinds noExtField)
 
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 6c8daa0d56..0393721df0 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -912,10 +912,10 @@ mkOneRecordSelector all_cons idDetails fl has_sel
     --    where cons_w_field = [C2,C7]
     sel_bind = mkTopFunBind Generated sel_lname alts
       where
-        alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
+        alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs (mapLoc CtxIdName sel_lname))
                                            [] unit_rhs]
              | otherwise =  map mk_match cons_w_field ++ deflt
-    mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
+    mk_match con = mkSimpleMatch (mkPrefixFunRhs (mapLoc CtxIdName sel_lname))
                                  [L loc' (mk_sel_pat con)]
                                  (L loc' (HsVar noExtField (L locn field_var)))
     mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 4ddb0ee000..cced5ed447 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -200,7 +200,7 @@ data SkolemInfo
   | FamInstSkol         -- Bound at a family instance decl
   | PatSkol             -- An existential type variable bound by a pattern for
       ConLike           -- a data constructor with an existential type.
-      (HsMatchContext GhcRn)
+      (HsMatchContext GhcTc)
              -- e.g.   data T = forall a. Eq a => MkT a
              --        f (MkT x) = ...
              -- The pattern MkT x will allocate an existential type
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 63055bbd48..87fc2d9750 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -180,7 +180,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
 cvtDec (TH.ValD pat body ds)
   | TH.VarP s <- pat
   = do  { s' <- vNameN s
-        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
+        ; cl' <- cvtClause (mkPrefixFunRhs (mapLoc CtxIdRdrName s')) (Clause [] body ds)
         ; th_origin <- getOrigin
         ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
 
@@ -201,7 +201,7 @@ cvtDec (TH.FunD nm cls)
                  <+> text "has no equations")
   | otherwise
   = do  { nm' <- vNameN nm
-        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs (mapLoc CtxIdRdrName nm'))) cls
         ; th_origin <- getOrigin
         ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
 
@@ -438,7 +438,7 @@ cvtDec (TH.PatSynD nm args dir pat)
     cvtDir _ Unidir          = return Unidirectional
     cvtDir _ ImplBidir       = return ImplicitBidirectional
     cvtDir n (ExplBidir cls) =
-      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
+      do { ms <- mapM (cvtClause (mkPrefixFunRhs (mapLoc CtxIdRdrName n))) cls
          ; th_origin <- getOrigin
          ; return $ ExplicitBidirectional $ mkMatchGroup th_origin (noLocA ms) }
 
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 171ce08bfa..aff5d17eb0 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -438,7 +438,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in GHC.Parser.Annotation
   | HsDo        (XDo p)                  -- Type of the whole expression
-                (HsStmtContext (HsDoRn p))
+                (HsStmtContext p)
                 -- The parameterisation of the above is unimportant
                 -- because in this context we never use
                 -- the PatGuard or ParStmt variant
@@ -613,7 +613,6 @@ data HsExpr p
 
 -- | The AST used to hard-refer to GhcPass, which was a layer violation. For now,
 -- we paper it over with this new extension point.
-type family HsDoRn p
 type family HsBracketRn p
 type family PendingRnSplice' p
 type family PendingTcSplice' p
@@ -1624,7 +1623,7 @@ data ArithSeqInfo id
 -- Context of a pattern match. This is more subtle than it would seem. See Note
 -- [Varieties of pattern matches].
 data HsMatchContext p
-  = FunRhs { mc_fun        :: LIdP p    -- ^ function binder of @f@
+  = FunRhs { mc_fun        :: XRec p (CtxIdP p) -- ^ function binder of @f@
            , mc_fixity     :: LexicalFixity -- ^ fixing of @f@
            , mc_strictness :: SrcStrictness -- ^ was @f@ banged?
                                             -- See Note [FunBind vs PatBind]
@@ -1714,7 +1713,7 @@ matchSeparator ThPatSplice  = panic "unused"
 matchSeparator ThPatQuote   = panic "unused"
 matchSeparator PatSyn       = panic "unused"
 
-pprMatchContext :: (Outputable (IdP p), UnXRec p)
+pprMatchContext :: (Outputable (CtxIdP p), UnXRec p)
                 => HsMatchContext p -> SDoc
 pprMatchContext ctxt
   | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
@@ -1724,7 +1723,7 @@ pprMatchContext ctxt
     want_an ProcExpr    = True
     want_an _           = False
 
-pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
+pprMatchContextNoun :: forall p. (Outputable (CtxIdP p), UnXRec p)
                     => HsMatchContext p -> SDoc
 pprMatchContextNoun (FunRhs {mc_fun=fun})
                                     = text "equation for"
@@ -1743,7 +1742,7 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
 pprMatchContextNoun PatSyn          = text "pattern synonym declaration"
 
 -----------------
-pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
+pprAStmtContext, pprStmtContext :: (Outputable (CtxIdP p), UnXRec p)
                                 => HsStmtContext p -> SDoc
 pprAStmtContext ctxt = article <+> pprStmtContext ctxt
   where
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index a9bef9b610..5514a068ed 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -150,6 +150,9 @@ class WrapXRec p a where
 -- | Maps the "normal" id type for a given pass
 type family IdP p
 
+-- | Maps the context id type for a given pass
+type family CtxIdP p
+
 type LIdP p = XRec p (IdP p)
 
 -- =====================================================================