TTG: Move CoreTickish out of LHS.Binds

Remove the `[CoreTickish]` fields from datatype `HsBindLR idL idR` and
move them to the extension point instance, according to the plan
outlined in #21592 to separate the base AST from the GHC specific bits.

13 files changed, 68 insertions, 55 deletions

diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index c08031c223..ed80c1349c 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -28,12 +28,13 @@ module GHC.Hs.Binds
 
 import GHC.Prelude
 
+import Language.Haskell.Syntax.Extension
 import Language.Haskell.Syntax.Binds
 
 import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind )
 import {-# SOURCE #-} GHC.Hs.Pat  (pprLPat )
 
-import Language.Haskell.Syntax.Extension
+import GHC.Types.Tickish
 import GHC.Hs.Extension
 import GHC.Parser.Annotation
 import GHC.Hs.Type
@@ -95,9 +96,11 @@ type instance XFunBind    (GhcPass pL) GhcRn = NameSet
 -- extension field contains the locally-bound free variables of this
 -- defn. See Note [Bind free vars]
 
-type instance XFunBind    (GhcPass pL) GhcTc = HsWrapper
--- ^ After the type-checker, the FunBind extension field contains a
--- coercion from the type of the MatchGroup to the type of the Id.
+        -- fun_tick :: [CoreTickish] 
+type instance XFunBind    (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish])
+-- ^ After the type-checker, the FunBind extension field contains
+-- the ticks to put on the rhs, if any, and a coercion from the
+-- type of the MatchGroup to the type of the Id.
 -- Example:
 --
 -- @
@@ -113,7 +116,10 @@ type instance XFunBind    (GhcPass pL) GhcTc = HsWrapper
 
 type instance XPatBind    GhcPs (GhcPass pR) = EpAnn [AddEpAnn]
 type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars]
-type instance XPatBind    GhcTc (GhcPass pR) = Type    -- Type of the GRHSs
+type instance XPatBind    GhcTc (GhcPass pR) =
+    ( Type                  -- Type of the GRHSs
+    , ( [CoreTickish]       -- Ticks to put on the rhs, if any
+      , [[CoreTickish]] ) ) -- and ticks to put on the bound variables.
 
 type instance XVarBind    (GhcPass pL) (GhcPass pR) = NoExtField
 type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField
@@ -512,13 +518,26 @@ ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
   = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
 ppr_monobind (FunBind { fun_id = fun,
                         fun_matches = matches,
-                        fun_tick = ticks,
-                        fun_ext = wrap })
-  = pprTicks empty (if null ticks then empty
-                    else text "-- ticks = " <> ppr ticks)
+                        fun_ext = ext })
+  = pprTicks empty ticksDoc
     $$  whenPprDebug (pprBndr LetBind (unLoc fun))
     $$  pprFunBind  matches
-    $$  whenPprDebug (pprIfTc @idR $ ppr wrap)
+    $$  whenPprDebug (pprIfTc @idR $ wrapDoc)
+        where
+            ticksDoc :: SDoc
+            ticksDoc = case ghcPass @idR of
+                         GhcPs -> empty
+                         GhcRn -> empty
+                         GhcTc | (_, ticks) <- ext ->
+                             if null ticks
+                                then empty
+                                else text "-- ticks = " <> ppr ticks
+            wrapDoc :: SDoc
+            wrapDoc = case ghcPass @idR of
+                        GhcPs -> empty
+                        GhcRn -> empty
+                        GhcTc | (wrap, _) <- ext -> ppr wrap
+
 
 ppr_monobind (PatSynBind _ psb) = ppr psb
 ppr_monobind (XHsBindsLR b) = case ghcPass @idL of
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 21e32825f5..557b3b2dd5 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -830,7 +830,7 @@ mkFunBind origin fn ms
   = FunBind { fun_id = fn
             , fun_matches = mkMatchGroup origin (noLocA ms)
             , fun_ext = noExtField
-            , fun_tick = [] }
+            }
 
 mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
              -> HsBind GhcRn
@@ -839,7 +839,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                     , fun_matches = mkMatchGroup origin (noLocA ms)
                                     , fun_ext  = emptyNameSet -- NB: closed
                                                               --     binding
-                                    , fun_tick = [] }
+                                    }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
 mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 44bb82312f..ea3191f5d6 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -154,8 +154,8 @@ dsHsBind dflags (VarBind { var_id = var
 
 dsHsBind dflags b@(FunBind { fun_id = L loc fun
                            , fun_matches = matches
-                           , fun_ext = co_fn
-                           , fun_tick = tick })
+                           , fun_ext = (co_fn, tick)
+                           })
  = do   { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $
                           -- FromSource might not be accurate (we don't have any
                           -- origin annotations for things in this module), but at
@@ -185,8 +185,8 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
           return (force_var, [core_binds]) }
 
 dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
-                         , pat_ext = ty
-                         , pat_ticks = (rhs_tick, var_ticks) })
+                         , pat_ext = (ty, (rhs_tick, var_ticks))
+                         })
   = do  { rhss_nablas <- pmcGRHSs PatBindGuards grhss
         ; body_expr <- dsGuarded grhss ty rhss_nablas
         ; let body' = mkOptTickBox rhs_tick body_expr
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 06405be8d7..7c1ab4ba5a 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -188,8 +188,8 @@ dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = []
 
 dsUnliftedBind (FunBind { fun_id = L l fun
                         , fun_matches = matches
-                        , fun_ext = co_fn
-                        , fun_tick = tick }) body
+                        , fun_ext = (co_fn, 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)) Nothing matches
@@ -199,7 +199,7 @@ dsUnliftedBind (FunBind { fun_id = L l fun
        ; return (bindNonRec fun rhs' body) }
 
 dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
-                        , pat_ext = ty }) body
+                        , pat_ext = (ty, _) }) body
   =     -- let C x# y# = rhs in body
         -- ==> case rhs of C x# y# -> body
     do { match_nablas <- pmcGRHSs PatBindGuards grhss
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index 892f74c966..f47ee5689e 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -53,6 +53,7 @@ import Data.List (isSuffixOf, intersperse)
 
 import Trace.Hpc.Mix
 
+import Data.Bifunctor (second)
 import Data.Set (Set)
 import qualified Data.Set as Set
 
@@ -286,7 +287,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
 
   let mbCons = maybe Prelude.id (:)
   return $ L pos $ funBind { fun_matches = mg
-                           , fun_tick = tick `mbCons` fun_tick funBind }
+                           , fun_ext = second (tick `mbCons`) (fun_ext funBind) }
   }
 
    where
@@ -317,7 +318,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
 
     let mbCons = maybe id (:)
 
-    let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'
+    let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat'
 
     -- Allocate the ticks
 
@@ -333,7 +334,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
           (zipWith mbCons patvar_ticks
                           (initial_patvar_tickss ++ repeat []))
 
-    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+    return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') }
 
 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index c1465bf0bc..553f872c29 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -836,11 +836,11 @@ type AnnoBody p body
 instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
   toHie (BC context scope b@(L span bind)) =
     concatM $ getTypeNode b : case bind of
-      FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
+      FunBind{fun_id = name, fun_matches = matches, fun_ext = ext} ->
         [ toHie $ C (ValBind context scope $ getRealSpanA span) name
         , toHie matches
         , case hiePass @p of
-            HieTc -> toHie $ L span wrap
+            HieTc | (wrap, _) <- ext -> toHie $ L span wrap
             _ -> pure []
         ]
       PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 9dabe3331d..486517ea2b 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -686,7 +686,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
     fromDecl (L loc decl@(ValD _ (PatBind _
                                  -- AZ: where should these anns come from?
                          pat@(L _ (ConPat noAnn ln@(L _ name) details))
-                               rhs _))) =
+                               rhs))) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr (locA loc) decl
            ; match <- case details of
@@ -1306,8 +1306,7 @@ makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
 makeFunBind fn ms
   = FunBind { fun_ext = noExtField,
               fun_id = fn,
-              fun_matches = mkMatchGroup FromSource ms,
-              fun_tick = [] }
+              fun_matches = mkMatchGroup FromSource ms }
 
 -- See Note [FunBind vs PatBind]
 checkPatBind :: SrcSpan
@@ -1329,7 +1328,7 @@ checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))
 
 checkPatBind loc annsIn lhs (L _ grhss) = do
   cs <- getCommentsFor loc
-  return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[]))
+  return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss)
 
 checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
 checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 539b36ddc2..16f6d49767 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -710,4 +710,4 @@ genFunBind fn ms
   = FunBind { fun_id = fn
             , fun_matches = mkMatchGroup Generated (wrapGenSpan ms)
             , fun_ext = emptyNameSet
-            , fun_tick = [] }
+            }
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 3db286e3e5..21d1424317 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -634,8 +634,8 @@ tcPolyCheck prag_fn
 
        ; let bind' = FunBind { fun_id      = L nm_loc poly_id2
                              , fun_matches = matches'
-                             , fun_ext     = wrap_gen <.> wrap_res
-                             , fun_tick    = tick }
+                             , fun_ext     = (wrap_gen <.> wrap_res, tick)
+                             }
 
              export = ABE { abe_wrap  = idHsWrapper
                           , abe_poly  = poly_id
@@ -1254,7 +1254,7 @@ tcMonoBinds is_rec sig_fn no_gen
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id,
                                fun_matches = matches',
-                               fun_ext = co_fn, fun_tick = [] },
+                               fun_ext = (co_fn, []) },
                   [MBI { mbi_poly_name = name
                        , mbi_sig       = Nothing
                        , mbi_mono_id   = mono_id }]) }
@@ -1275,7 +1275,7 @@ tcMonoBinds is_rec sig_fn no_gen
 
        ; return ( unitBag $ L b_loc $
                      PatBind { pat_lhs = pat', pat_rhs = grhss'
-                             , pat_ext = pat_ty, pat_ticks = ([],[]) }
+                             , pat_ext = (pat_ty, ([],[])) }
 
                 , mbis ) }
   where
@@ -1507,8 +1507,8 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
                                  matches (mkCheckExpType $ idType mono_id)
         ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
                            , fun_matches = matches'
-                           , fun_ext = co_fn
-                           , fun_tick = [] } ) }
+                           , fun_ext = (co_fn, [])
+                           } ) }
 
 tcRhs (TcPatBind infos pat' grhss pat_ty)
   = -- When we are doing pattern bindings we *don't* bring any scoped
@@ -1521,8 +1521,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
                     tcGRHSsPat grhss (mkCheckExpType pat_ty)
 
         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
-                           , pat_ext = pat_ty
-                           , pat_ticks = ([],[]) } )}
+                           , pat_ext = (pat_ty, ([],[])) } )}
 
 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
 tcExtendTyVarEnvForRhs Nothing thing_inside
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 8da94d2ec0..7fd1f3677f 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -857,8 +857,8 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
 
        ; let bind = FunBind{ fun_id = L loc matcher_prag_id
                            , fun_matches = mg
-                           , fun_ext = idHsWrapper
-                           , fun_tick = [] }
+                           , fun_ext = (idHsWrapper, [])
+                           }
              matcher_bind = unitBag (noLocA bind)
        ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id))
        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
@@ -959,7 +959,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
              bind = FunBind { fun_id      = L loc (idName builder_id)
                             , fun_matches = match_group'
                             , fun_ext     = emptyNameSet
-                            , fun_tick    = [] }
+                            }
 
              sig = completeSigFromId (PatSynCtxt ps_name) builder_id
 
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index e8b5f8252e..f11bc29000 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -535,12 +535,12 @@ zonk_lbind env = wrapLocMA (zonk_bind env)
 
 zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc)
 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
-                            , pat_ext = ty})
+                            , pat_ext = (ty, ticks)})
   = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
         ; new_grhss <- zonkGRHSs env zonkLExpr grhss
         ; new_ty    <- zonkTcTypeToTypeX env ty
         ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
-                       , pat_ext = new_ty }) }
+                       , pat_ext = (new_ty, ticks) }) }
 
 zonk_bind env (VarBind { var_ext = x
                        , var_id = var, var_rhs = expr })
@@ -552,13 +552,13 @@ zonk_bind env (VarBind { var_ext = x
 
 zonk_bind env bind@(FunBind { fun_id = L loc var
                             , fun_matches = ms
-                            , fun_ext = co_fn })
+                            , fun_ext = (co_fn, ticks) })
   = do { new_var <- zonkIdBndr env var
        ; (env1, new_co_fn) <- zonkCoFn env co_fn
        ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
        ; return (bind { fun_id = L loc new_var
                       , fun_matches = new_ms
-                      , fun_ext = new_co_fn }) }
+                      , fun_ext = (new_co_fn, ticks) }) }
 
 zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                                     , abs_ev_binds = ev_binds
@@ -585,7 +585,7 @@ zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
       | has_sig
       , (L loc bind@(FunBind { fun_id      = (L mloc mono_id)
                              , fun_matches = ms
-                             , fun_ext     = co_fn })) <- lbind
+                             , fun_ext     = (co_fn, ticks) })) <- lbind
       = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id
                             -- Specifically /not/ zonkIdBndr; we do not want to
                             -- complain about a representation-polymorphic binder
@@ -594,7 +594,7 @@ zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
            ; return $ L loc $
              bind { fun_id      = L mloc new_mono_id
                   , fun_matches = new_ms
-                  , fun_ext     = new_co_fn } }
+                  , fun_ext     = (new_co_fn, ticks) } }
       | otherwise
       = zonk_lbind env lbind   -- The normal case
 
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 0432de43fa..9594927da3 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -222,7 +222,7 @@ cvtDec (TH.ValD pat body ds)
           PatBind { pat_lhs = pat'
                   , pat_rhs = GRHSs emptyComments body' ds'
                   , pat_ext = noAnn
-                  , pat_ticks = ([],[]) } }
+                  } }
 
 cvtDec (TH.FunD nm cls)
   | null cls
diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
index 467304af53..22f2116b04 100644
--- a/compiler/Language/Haskell/Syntax/Binds.hs
+++ b/compiler/Language/Haskell/Syntax/Binds.hs
@@ -31,8 +31,7 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Pat
 import Language.Haskell.Syntax.Extension
 import Language.Haskell.Syntax.Type
 
-import GHC.Types.Basic
-import GHC.Types.Tickish
+import GHC.Types.Basic (InlinePragma)
 import GHC.Types.Fixity
 import GHC.Data.Bag
 
@@ -200,9 +199,8 @@ data HsBindLR idL idR
 
         fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr
 
-        fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload
+        fun_matches :: MatchGroup idR (LHsExpr idR)  -- ^ The payload
 
-        fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any
     }
 
   -- | Pattern Binding
@@ -221,10 +219,7 @@ data HsBindLR idL idR
   | PatBind {
         pat_ext    :: XPatBind idL idR,
         pat_lhs    :: LPat idL,
-        pat_rhs    :: GRHSs idR (LHsExpr idR),
-        pat_ticks  :: ([CoreTickish], [[CoreTickish]])
-               -- ^ Ticks to put on the rhs, if any, and ticks to put on
-               -- the bound variables.
+        pat_rhs    :: GRHSs idR (LHsExpr idR)
     }
 
   -- | Variable Binding