Remove NoGhcTc usage from HsMatchContext

NoGhcTc is removed from HsMatchContext. As a result of this,
HsMatchContext GhcTc is now a valid type that has Id in it,
instead of Name and tcMatchesFun now takes Id instead of Name.

13 files changed, 70 insertions, 39 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 06cc4cd946..2bb6fc7d98 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1892,9 +1892,10 @@ pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)
 
 pprStmtInCtxt :: (OutputableBndrId idL,
                   OutputableBndrId idR,
+                  OutputableBndrId ctx,
                   Outputable body,
                  Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)
-              => HsStmtContext (GhcPass idL)
+              => HsStmtContext (GhcPass ctx)
               -> StmtLR (GhcPass idL) (GhcPass idR) body
               -> SDoc
 pprStmtInCtxt ctxt (LastStmt _ e _ _)
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 42669f4c2c..3f29455032 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -174,7 +174,7 @@ mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
                         ~ SrcSpanAnnA,
                   Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
                         ~ SrcSpan)
-              => HsMatchContext (NoGhcTc (GhcPass p))
+              => HsMatchContext (GhcPass p)
               -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
               -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
 mkSimpleMatch ctxt pats rhs
@@ -913,7 +913,7 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
 
 ------------
 mkMatch :: forall p. IsPass p
-        => HsMatchContext (NoGhcTc (GhcPass p))
+        => HsMatchContext (GhcPass p)
         -> [LPat (GhcPass p)]
         -> LHsExpr (GhcPass p)
         -> HsLocalBinds (GhcPass p)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index f4cc42949a..d20a7bb77f 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -933,7 +933,13 @@ instance ( HiePass p
         HieRn -> makeNodeA m span
 
 instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
-  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name'
+    where
+      -- See a paragraph about Haddock in #20415.
+      name' :: LocatedN Name
+      name' = case hiePass @p of
+        HieRn -> name
+        HieTc -> mapLoc varName name
   toHie (StmtCtxt a) = toHie a
   toHie _ = pure []
 
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 4caa73e625..207f83cb51 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -275,7 +275,7 @@ tc_cmd env
         ; return (mkHsCmdWrap (mkWpCastN co) cmd') }
   where
     n_pats     = length pats
-    match_ctxt = (LambdaExpr :: HsMatchContext GhcRn)    -- Maybe KappaExpr?
+    match_ctxt = LambdaExpr    -- Maybe KappaExpr?
     pg_ctxt    = PatGuard match_ctxt
 
     tc_grhss (GRHSs x grhss binds) stk_ty res_ty
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 368248dc28..e540e3db91 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -622,7 +622,7 @@ tcPolyCheck prag_fn
                 --    See Note [Relevant bindings and the binder stack]
 
                 setSrcSpanA bind_loc $
-                tcMatchesFun (L nm_loc mono_name) matches
+                tcMatchesFun (L nm_loc mono_id) matches
                              (mkCheckExpType rho_ty)
 
        -- We make a funny AbsBinds, abstracting over nothing,
@@ -1189,15 +1189,19 @@ tcMonoBinds is_rec sig_fn no_gen
   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
   , Nothing <- sig_fn name   -- ...with no type signature
   = setSrcSpanA b_loc    $
-    do  { ((co_fn, matches'), rhs_ty)
-            <- tcInfer $ \ exp_ty ->
-               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
-                  -- We extend the error context even for a non-recursive
-                  -- function so that in type error messages we show the
-                  -- type of the thing whose rhs we are type checking
-               tcMatchesFun (L nm_loc name) matches exp_ty
-
-        ; mono_id <- newLetBndr no_gen name Many rhs_ty
+    do  { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->
+                                          -- See Note [fixM for rhs_ty in tcMonoBinds]
+            do  { mono_id <- newLetBndr no_gen name Many rhs_ty
+                ; (matches', rhs_ty')
+                    <- tcInfer $ \ exp_ty ->
+                       tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
+                          -- We extend the error context even for a non-recursive
+                          -- function so that in type error messages we show the
+                          -- type of the thing whose rhs we are type checking
+                       tcMatchesFun (L nm_loc mono_id) matches exp_ty
+                ; return (matches', mono_id, rhs_ty')
+                }
+
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id,
                                fun_matches = matches',
@@ -1309,6 +1313,20 @@ Here we want to push p's signature inwards, i.e. /checking/, to
 correctly elaborate 'id'. But we want to /infer/ q's higher rank
 type.  There seems to be no way to do this.  So currently we only
 switch to inference when we have no signature for any of the binders.
+
+Note [fixM for rhs_ty in tcMonoBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In order to create mono_id we need rhs_ty but we don't have it yet,
+we only get it from tcMatchesFun later (which needs mono_id to put
+into HsMatchContext for pretty printing). To solve this, create
+a thunk of rhs_ty with fixM that we fill in later.
+
+This is fine only because neither newLetBndr or tcMatchesFun look
+at the varType field of the Id. tcMatchesFun only looks at idName
+of mono_id.
+
+Also see #20415 for the bigger picture of why tcMatchesFun needs
+mono_id in the first place.
 -}
 
 
@@ -1436,7 +1454,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
   = tcExtendIdBinderStackForRhs [info]  $
     tcExtendTyVarEnvForRhs mb_sig       $
     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
-        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))
+        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)
                                  matches (mkCheckExpType $ idType mono_id)
         ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
                            , fun_matches = matches'
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index d1bca5d663..c8eb8fd233 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -91,12 +91,12 @@ is used in error messages.  It checks that all the equations have the
 same number of arguments before using @tcMatches@ to do the work.
 -}
 
-tcMatchesFun :: LocatedN Name
+tcMatchesFun :: LocatedN Id -- MatchContext Id
              -> MatchGroup GhcRn (LHsExpr GhcRn)
              -> ExpRhoType    -- Expected type of function
              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
                                 -- Returns type of body
-tcMatchesFun fn@(L _ fun_name) matches exp_ty
+tcMatchesFun fun_id matches exp_ty
   = do  {  -- Check that they all have the same no of arguments
            -- Location is in the monad, set the caller so that
            -- any inter-equation error messages get some vaguely
@@ -118,12 +118,18 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
           -- a multiplicity argument, and scale accordingly.
           tcMatches match_ctxt pat_tys rhs_ty matches }
   where
+    fun_name = idName (unLoc fun_id)
     arity  = matchGroupArity matches
     herald = text "The equation(s) for"
              <+> 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 = fun_id, mc_fixity = Prefix, mc_strictness = strictness }
+                    -- Careful: this fun_id could be an unfilled
+                    -- thunk from fixM in tcMonoBinds, so we're
+                    -- not allowed to look at it, except for
+                    -- idName.
+                    -- See Note [fixM for rhs_ty in tcMonoBinds]
     match_ctxt = MC { mc_what = what, mc_body = tcBody }
     strictness
       | [L _ match] <- unLoc $ mg_alts matches
@@ -186,7 +192,7 @@ 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
@@ -345,13 +351,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
@@ -361,7 +367,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
@@ -999,7 +1005,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/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot
index 9f6b6bf239..dee8e0721e 100644
--- a/compiler/GHC/Tc/Gen/Match.hs-boot
+++ b/compiler/GHC/Tc/Gen/Match.hs-boot
@@ -1,17 +1,17 @@
 module GHC.Tc.Gen.Match where
 import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr )
 import GHC.Tc.Types.Evidence  ( HsWrapper )
-import GHC.Types.Name   ( Name )
 import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType )
 import GHC.Tc.Types     ( TcM )
 import GHC.Hs.Extension ( GhcRn, GhcTc )
 import GHC.Parser.Annotation ( LocatedN )
+import GHC.Types.Id (Id)
 
 tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)
               -> ExpRhoType
               -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
 
-tcMatchesFun :: LocatedN Name
+tcMatchesFun :: LocatedN Id
              -> MatchGroup GhcRn (LHsExpr GhcRn)
              -> ExpSigmaType
              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 10c862f8f6..82d707dd76 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -97,7 +97,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
@@ -119,7 +119,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
@@ -128,14 +128,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
@@ -162,7 +162,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/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index fa4cd8fecf..c62ec59e1c 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -781,6 +781,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
        ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
+             patsyn_id     = mkExportedVanillaId name matcher_sigma
                              -- See Note [Exported LocalIds] in GHC.Types.Id
 
              inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
@@ -808,7 +809,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 patsyn_id)) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
                                        req_dicts body')
                              (EmptyLocalBinds noExtField)
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index e66a83f5bb..8c37480297 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -220,7 +220,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/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 1c990cba9f..6183e51ead 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -296,8 +296,7 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId
 
 -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal"
 mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id
-mkLocalId name w ty = assert (not (isCoVarType ty)) $
-                      mkLocalIdWithInfo name w ty vanillaIdInfo
+mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo
 
 -- | Make a local CoVar
 mkLocalCoVar :: Name -> Type -> CoVar
@@ -318,8 +317,8 @@ mkLocalIdOrCoVar name w ty
 
     -- proper ids only; no covars!
 mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id
-mkLocalIdWithInfo name w ty info = assert (not (isCoVarType ty)) $
-                                   Var.mkLocalVar VanillaId name w ty info
+mkLocalIdWithInfo name w ty info =
+  Var.mkLocalVar VanillaId name w (assert (not (isCoVarType ty)) ty) info
         -- Note [Free type variables]
 
 -- | Create a local 'Id' that is marked as exported.
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 34058b58f5..29769b6e93 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1067,7 +1067,7 @@ type LMatch id body = XRec id (Match id body)
 data Match p body
   = Match {
         m_ext :: XCMatch p body,
-        m_ctxt :: HsMatchContext (NoGhcTc p),
+        m_ctxt :: HsMatchContext p,
           -- See note [m_ctxt in Match]
         m_pats :: [LPat p], -- The patterns
         m_grhss :: (GRHSs p body)
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index 31016f531b..addb3d0ff2 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -1563,7 +1563,7 @@
              (FunRhs
               (L
                (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 })
-               {Name: main})
+               {Var: main})
               (Prefix)
               (NoSrcStrict))
              []