Only store Name in FunRhs rather than Id with knot-tied fields

All the issues here have been caused by #18758.
The goal of the ticket is to be able to talk about things like
`LTyClDecl GhcTc`. In the case of HsMatchContext,
the correct "context" is whatever we want, and in fact storing just a
`Name` is sufficient and correct context, even if the rest of the AST is
storing typechecker Ids.

So this reverts (#20415, !5579) which intended to get closed to #18758 but
didn't really and introduced a few subtle bugs.

Printing of an error message in #22695 would just hang, because we would
attempt to print the `Id` in debug mode to assertain whether it was
empty or not. Printing the Name is fine for the error message.

Another consequence is that when `-dppr-debug` was enabled the compiler would
hang because the debug printing of the Id would try and print fields
which were not populated yet.

This also led to 32070e6c2e1b4b7c32530a9566fe14543791f9a6 having to add
a workaround for the `checkArgs` function which was probably a very
similar bug to #22695.

Fixes #22695

10 files changed, 33 insertions, 74 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 1b8fa065bb..ed0280cb18 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -2002,7 +2002,7 @@ matchSeparator ThPatSplice  = panic "unused"
 matchSeparator ThPatQuote   = panic "unused"
 matchSeparator PatSyn       = panic "unused"
 
-pprMatchContext :: (Outputable (IdP p), UnXRec p)
+pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
                 => HsMatchContext p -> SDoc
 pprMatchContext ctxt
   | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
@@ -2013,10 +2013,10 @@ pprMatchContext ctxt
     want_an (ArrowMatchCtxt KappaExpr) = True
     want_an _                          = False
 
-pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
+pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
                     => HsMatchContext p -> SDoc
 pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for"
-                                              <+> quotes (ppr (unXRec @p fun))
+                                                <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
 pprMatchContextNoun CaseAlt                 = text "case alternative"
 pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant
                                               <+> text "alternative"
@@ -2032,10 +2032,10 @@ pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"
                                               $$ pprAStmtContext ctxt
 pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"
 
-pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)
+pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
                      => HsMatchContext p -> SDoc
 pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for"
-                                               <+> quotes (ppr (unXRec @p fun))
+                                               <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
 pprMatchContextNouns PatBindGuards           = text "pattern binding guards"
 pprMatchContextNouns (ArrowMatchCtxt c)      = pprArrowMatchContextNouns c
 pprMatchContextNouns (StmtCtxt ctxt)         = text "pattern bindings in"
@@ -2056,7 +2056,7 @@ pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_varia
 pprArrowMatchContextNouns ctxt                         = pprArrowMatchContextNoun ctxt <> char 's'
 
 -----------------
-pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
+pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
                                 => HsStmtContext p -> SDoc
 pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour
 pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 486e4810d4..af222bf98a 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -863,7 +863,7 @@ mkSimpleGeneratedFunBind loc fun pats expr
                        emptyLocalBinds]
 
 -- | Make a prefix, non-strict function 'HsMatchContext'
-mkPrefixFunRhs :: LIdP p -> HsMatchContext p
+mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p
 mkPrefixFunRhs n = FunRhs { mc_fun = n
                           , mc_fixity = Prefix
                           , mc_strictness = NoSrcStrict }
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index bf9a38e279..8ede7bcc5f 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -957,7 +957,7 @@ instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
       name' :: LocatedN Name
       name' = case hiePass @p of
         HieRn -> name
-        HieTc -> fmap varName name
+        HieTc -> name
   toHie (StmtCtxt a) = toHie a
   toHie _ = pure []
 
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 00b37709bd..f135826147 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -927,14 +927,10 @@ instance Diagnostic TcRnMessage where
           same_rec_group_msg = text "it is defined and used in the same recursive group"
     TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches)
       -> mkSimpleDecorated $
-           (vcat [ pprArgsContext argsContext <+>
+           (vcat [ pprMatchContextNouns argsContext <+>
                    text "have different numbers of arguments"
                  , nest 2 (ppr (getLocA match1))
                  , nest 2 (ppr (getLocA (NE.head bad_matches)))])
-        where
-          pprArgsContext = \case
-            EquationArgs name -> (text "Equations for" <+>) . quotes $ ppr name
-            PatternArgs matchCtx -> pprMatchContextNouns matchCtx
     TcRnCannotBindScopedTyVarInPatSig sig_tvs
       -> mkSimpleDecorated $
            hang (text "You cannot bind scoped type variable"
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index f4d7d85ed1..990c97970c 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2094,7 +2094,7 @@ data TcRnMessage where
                 typecheck/should_fail/T20768_fail
   -}
   TcRnMatchesHaveDiffNumArgs
-    :: !MatchArgsContext
+    :: !(HsMatchContext GhcTc) -- ^ Pattern match specifics
     -> !MatchArgBadMatches
     -> TcRnMessage
 
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 65202cdeb2..0f06b5f9d7 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -172,7 +172,7 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
 tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty
   = addErrCtxt (cmdCtxt cmd)
       do { let match_ctxt = ArrowLamCaseAlt lc_variant
-         ; checkPatCounts (ArrowMatchCtxt match_ctxt) match
+         ; checkArgCounts (ArrowMatchCtxt match_ctxt) match
          ; (wrap, match') <-
              tcCmdMatchLambda env match_ctxt match cmd_ty
          ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index cf2cac142b..6441fe991a 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -624,7 +624,7 @@ tcPolyCheck prag_fn
                 --    See Note [Relevant bindings and the binder stack]
 
                 setSrcSpanA bind_loc $
-                tcMatchesFun (L nm_loc mono_id) matches
+                tcMatchesFun (L nm_loc (idName mono_id)) matches
                              (mkCheckExpType rho_ty)
 
        -- We make a funny AbsBinds, abstracting over nothing,
@@ -1263,18 +1263,14 @@ 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'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->
-                                          -- See Note [fixM for rhs_ty in tcMonoBinds]
-            do  { mono_id <- newLetBndr no_gen name ManyTy rhs_ty
-                ; (matches', rhs_ty')
-                    <- tcInfer $ \ exp_ty ->
+    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 mono_id) matches exp_ty
-                ; return (matches', mono_id, rhs_ty')
-                }
+                       tcMatchesFun (L nm_loc name) matches exp_ty
+       ; mono_id <- newLetBndr no_gen name ManyTy rhs_ty'
 
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id,
@@ -1388,19 +1384,6 @@ 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.
 -}
 
 
@@ -1528,7 +1511,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) mono_id)
+        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName 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 7c331fb970..1d2b789261 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -31,7 +31,7 @@ module GHC.Tc.Gen.Match
    , tcBody
    , tcDoStmt
    , tcGuardStmt
-   , checkPatCounts
+   , checkArgCounts
    )
 where
 
@@ -93,12 +93,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 Id -- MatchContext Id
+tcMatchesFun :: LocatedN Name -- MatchContext Id
              -> MatchGroup GhcRn (LHsExpr GhcRn)
              -> ExpRhoType    -- Expected type of function
              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
                                 -- Returns type of body
-tcMatchesFun fun_id matches exp_ty
+tcMatchesFun fun_name 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
@@ -106,9 +106,7 @@ tcMatchesFun fun_id matches exp_ty
            -- ann-grabbing, because we don't always have annotations in
            -- hand when we call tcMatchesFun...
           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
-           -- We can't easily call checkPatCounts here because fun_id can be an
-           -- unfilled thunk
-        ; checkArgCounts fun_name matches
+        ; checkArgCounts what matches
 
         ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
              -- NB: exp_type may be polymorphic, but
@@ -122,17 +120,11 @@ tcMatchesFun fun_id 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 = ExpectedFunTyMatches (NameThing fun_name) matches
+    herald = ExpectedFunTyMatches (NameThing (unLoc fun_name)) matches
     ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True
                          -- But that's wrong for f :: Int -> forall a. blah
-    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]
+    what   = FunRhs { mc_fun = fun_name, mc_fixity = Prefix, mc_strictness = strictness }
     match_ctxt = MC { mc_what = what, mc_body = tcBody }
     strictness
       | [L _ match] <- unLoc $ mg_alts matches
@@ -164,7 +156,7 @@ tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys
               -> ExpRhoType
               -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
 tcMatchLambda herald match_ctxt match res_ty
-  =  do { checkPatCounts (mc_what match_ctxt) match
+  =  do { checkArgCounts (mc_what match_ctxt) match
         ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do
             -- checking argument counts since this is also used for \cases
             tcMatches match_ctxt pat_tys rhs_ty match }
@@ -1136,28 +1128,16 @@ the variables they bind into scope, and typecheck the thing_inside.
 \subsection{Errors and contexts}
 *                                                                      *
 ************************************************************************
-
-@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
-number of args are used in each equation.
 -}
 
+-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
+-- number of args are used in each equation.
 checkArgCounts :: AnnoBody body
-               => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
-checkArgCounts = check_match_pats . EquationArgs
-
--- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same
--- number of patterns are used in each alternative
-checkPatCounts :: AnnoBody body
-               => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
-               -> TcM ()
-checkPatCounts = check_match_pats . PatternArgs
-
-check_match_pats :: AnnoBody body
-                 => MatchArgsContext -> MatchGroup GhcRn (LocatedA (body GhcRn))
-                 -> TcM ()
-check_match_pats _ (MG { mg_alts = L _ [] })
+          => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
+          -> TcM ()
+checkArgCounts _ (MG { mg_alts = L _ [] })
     = return ()
-check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) })
+checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
     | Just bad_matches <- mb_bad_matches
     = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext
                  $ MatchArgMatches match1 bad_matches
diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot
index dee8e0721e..80790f2f9c 100644
--- a/compiler/GHC/Tc/Gen/Match.hs-boot
+++ b/compiler/GHC/Tc/Gen/Match.hs-boot
@@ -5,13 +5,13 @@ 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)
+import GHC.Types.Name (Name)
 
 tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)
               -> ExpRhoType
               -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
 
-tcMatchesFun :: LocatedN Id
+tcMatchesFun :: LocatedN Name
              -> MatchGroup GhcRn (LHsExpr GhcRn)
              -> ExpSigmaType
              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 4c691185aa..8741770977 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -838,7 +838,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
                                                          args body]
                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
                        }
-             match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []
+             match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
                                        req_dicts body')
                              (EmptyLocalBinds noExtField)