{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImplicitParams #-} -- used in TH splice
module Graph.Trace.Internal.Instrument
  ( modifyValBinds
  , modifyTyClDecl
  , modifyClsInstDecl
  ) where

import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Class (lift)
import           Control.Monad.Trans.State.Strict
import           Control.Monad.Trans.Writer.CPS
import qualified Data.Generics as Syb
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import           GHC.Magic (noinline)
import qualified Language.Haskell.TH as TH
import           System.IO.Unsafe (unsafePerformIO)
import qualified System.Random as Rand

import qualified Graph.Trace.Internal.GhcFacade as Ghc
import           Graph.Trace.Internal.Types

-- | Instrument value bindings that have a signature with a debug pred.
-- This gets applied to both top level bindings as well as arbitrarily nested
-- value bindings.
modifyValBinds
  :: DebugNames
  -> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
  -> Ghc.NHsValBindsLR Ghc.GhcRn
  -> WriterT
       (S.Set Ghc.Name)
       (StateT (S.Set Ghc.Name) Ghc.TcM)
       (Ghc.NHsValBindsLR Ghc.GhcRn)
modifyValBinds :: DebugNames
-> Map Name (Maybe FastString, Propagation)
-> NHsValBindsLR GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (NHsValBindsLR GhcRn)
modifyValBinds DebugNames
debugNames Map Name (Maybe FastString, Propagation)
nameMap (Ghc.NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs) = do
  [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
binds' <-
    (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
      (Map Name (Maybe FastString, Propagation)
-> DebugNames
-> LHsBinds GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames)
      [(RecFlag, LHsBinds GhcRn)]
binds
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (forall a. Ord a => Set a -> Set a -> Set a
S.union forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
M.keysSet Map Name (Maybe FastString, Propagation)
nameMap)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
Ghc.NValBinds [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
binds' [LSig GhcRn]
sigs

-- | Instrument default method implementations in a type class declaration if
-- they contain a Debug pred.
modifyTyClDecl
  :: DebugNames
  -> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
  -> Ghc.TyClDecl Ghc.GhcRn
  -> WriterT
       (S.Set Ghc.Name)
       (StateT (S.Set Ghc.Name) Ghc.TcM)
       (Ghc.TyClDecl Ghc.GhcRn)
modifyTyClDecl :: DebugNames
-> Map Name (Maybe FastString, Propagation)
-> TyClDecl GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (TyClDecl GhcRn)
modifyTyClDecl DebugNames
debugNames Map Name (Maybe FastString, Propagation)
nameMap
    cd :: TyClDecl GhcRn
cd@Ghc.ClassDecl { tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
Ghc.tcdMeths = LHsBinds GhcRn
meths
                     } = do
  Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
newMeths <- Map Name (Maybe FastString, Propagation)
-> DebugNames
-> LHsBinds GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames LHsBinds GhcRn
meths
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TyClDecl GhcRn
cd { tcdMeths :: LHsBinds GhcRn
Ghc.tcdMeths = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
newMeths }
modifyTyClDecl DebugNames
_ Map Name (Maybe FastString, Propagation)
_ TyClDecl GhcRn
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure TyClDecl GhcRn
x

-- | Instrument the method implementations in an type class instance if it has
-- a signature containing a debug pred.
modifyClsInstDecl
  :: DebugNames
  -> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
  -> Ghc.ClsInstDecl Ghc.GhcRn
  -> WriterT
       (S.Set Ghc.Name)
       (StateT (S.Set Ghc.Name) Ghc.TcM)
       (Ghc.ClsInstDecl Ghc.GhcRn)
modifyClsInstDecl :: DebugNames
-> Map Name (Maybe FastString, Propagation)
-> ClsInstDecl GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (ClsInstDecl GhcRn)
modifyClsInstDecl DebugNames
debugNames Map Name (Maybe FastString, Propagation)
nameMap
    inst :: ClsInstDecl GhcRn
inst@Ghc.ClsInstDecl{ cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
Ghc.cid_binds = LHsBinds GhcRn
binds }
      = do
  Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
newBinds <- Map Name (Maybe FastString, Propagation)
-> DebugNames
-> LHsBinds GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames LHsBinds GhcRn
binds
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ClsInstDecl GhcRn
inst { cid_binds :: LHsBinds GhcRn
Ghc.cid_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
newBinds }
#if !(MIN_VERSION_ghc(9,0,0))
modifyClsInstDecl _ _ x = pure x
#endif

-- | Instrument a set of bindings given a Map containing the names of functions
-- that should be modified.
modifyBinds
  :: M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
  -> DebugNames
  -> Ghc.LHsBinds Ghc.GhcRn
  -> WriterT
       (S.Set Ghc.Name)
       (StateT (S.Set Ghc.Name) Ghc.TcM)
       (Ghc.LHsBinds Ghc.GhcRn)
modifyBinds :: Map Name (Maybe FastString, Propagation)
-> DebugNames
-> LHsBinds GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames =
  (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
    (Map Name (Maybe FastString, Propagation)
-> DebugNames
-> HsBindLR GhcRn GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (HsBindLR GhcRn GhcRn)
modifyBinding Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames)

-- | Instrument a binding if its name is in the Map.
modifyBinding
  :: M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
  -> DebugNames
  -> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn
  -> WriterT
       (S.Set Ghc.Name)
       (StateT (S.Set Ghc.Name) Ghc.TcM)
       (Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn)
modifyBinding :: Map Name (Maybe FastString, Propagation)
-> DebugNames
-> HsBindLR GhcRn GhcRn
-> WriterT
     (Set Name)
     (StateT (Set Name) (IOEnv (Env TcGblEnv TcLclEnv)))
     (HsBindLR GhcRn GhcRn)
modifyBinding Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames
  bnd :: HsBindLR GhcRn GhcRn
bnd@Ghc.FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
Ghc.fun_id = Ghc.L' SrcSpan
loc Name
name
                  , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
Ghc.fun_matches = mg :: MatchGroup GhcRn (LHsExpr GhcRn)
mg@(Ghc.MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
Ghc.mg_alts = XRec GhcRn [LMatch GhcRn (LHsExpr GhcRn)]
alts }) }
    | Just (Maybe FastString
mUserKey, Propagation
prop) <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name Map Name (Maybe FastString, Propagation)
nameMap
    = do
      let key :: Either FunName FunName
key = case Maybe FastString
mUserKey of
                  Maybe FastString
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> FunName
Ghc.getOccString Name
name
                  Just FastString
k -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FastString -> FunName
Ghc.unpackFS FastString
k

      GenLocated SrcSpanAnnA (HsExpr GhcRn)
whereBindExpr <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Either FunName FunName -> Propagation -> TcM (LHsExpr GhcRn)
mkNewIpExpr SrcSpan
loc Either FunName FunName
key Propagation
prop

      GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
newAlts <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
        (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
          (Propagation
-> LHsExpr GhcRn
-> DebugNames
-> Match GhcRn (LHsExpr GhcRn)
-> StateT
     (Set Name)
     (IOEnv (Env TcGblEnv TcLclEnv))
     (Match GhcRn (LHsExpr GhcRn))
modifyMatch Propagation
prop GenLocated SrcSpanAnnA (HsExpr GhcRn)
whereBindExpr DebugNames
debugNames)
          XRec GhcRn [LMatch GhcRn (LHsExpr GhcRn)]
alts

      forall (f :: * -> *) a. Applicative f => a -> f a
pure HsBindLR GhcRn GhcRn
bnd{fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
Ghc.fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg{ mg_alts :: XRec GhcRn [LMatch GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
Ghc.mg_alts = GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
newAlts }}
modifyBinding Map Name (Maybe FastString, Propagation)
nameMap DebugNames
_
  bnd :: HsBindLR GhcRn GhcRn
bnd@Ghc.PatBind{ pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
Ghc.pat_lhs = LPat GhcRn
pat } = do
    -- Collect the 'Name's appearing in pattern bindings so that if they have
    -- type signatures, the predicate can be removed if monomorphism
    -- restriction is on.
    let collectName :: Ghc.Pat Ghc.GhcRn -> S.Set Ghc.Name
        collectName :: Pat GhcRn -> Set Name
collectName = \case
          Ghc.VarPat XVarPat GhcRn
_ (forall l e. GenLocated l e -> e
Ghc.unLoc -> Name
name)
            | forall k a. Ord k => k -> Map k a -> Bool
M.member Name
name Map Name (Maybe FastString, Propagation)
nameMap -> forall a. a -> Set a
S.singleton Name
name
#if MIN_VERSION_ghc(9,6,0)
          Ghc.AsPat _ (Ghc.unLoc -> name) _ _
#else
          Ghc.AsPat XAsPat GhcRn
_ (forall l e. GenLocated l e -> e
Ghc.unLoc -> Name
name) LPat GhcRn
_
#endif
            | forall k a. Ord k => k -> Map k a -> Bool
M.member Name
name Map Name (Maybe FastString, Propagation)
nameMap -> forall a. a -> Set a
S.singleton Name
name
          Pat GhcRn
_ -> forall a. Monoid a => a
mempty
        vars :: Set Name
vars = forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
Syb.everything forall a. Semigroup a => a -> a -> a
(<>) (forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
Syb.mkQ forall a. Monoid a => a
mempty Pat GhcRn -> Set Name
collectName) LPat GhcRn
pat
    forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell Set Name
vars
    forall (f :: * -> *) a. Applicative f => a -> f a
pure HsBindLR GhcRn GhcRn
bnd
modifyBinding Map Name (Maybe FastString, Propagation)
_ DebugNames
_ HsBindLR GhcRn GhcRn
bnd = forall (f :: * -> *) a. Applicative f => a -> f a
pure HsBindLR GhcRn GhcRn
bnd

-- | Generate the Name for the where binding
mkWhereBindName :: Ghc.TcM Ghc.Name
mkWhereBindName :: TcM Name
mkWhereBindName = do
  Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
Ghc.getUniqueM
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Unique -> FastString -> Name
Ghc.mkSystemVarName Unique
uniq FastString
"new_debug_ip"

-- | Creates a FunBind that will be placed in the where block of a function to
-- serve as the sole definition site of the new DebugContext for that function.
mkWhereBinding :: Ghc.Name -> Ghc.LHsExpr Ghc.GhcRn -> Ghc.LHsBind Ghc.GhcRn
mkWhereBinding :: Name -> LHsExpr GhcRn -> LHsBind GhcRn
mkWhereBinding Name
whereBindName LHsExpr GhcRn
whereBindExpr =
  forall a an. a -> LocatedAn an a
Ghc.noLocA' Ghc.FunBind'
    { fun_ext' :: XFunBind GhcRn GhcRn
Ghc.fun_ext' = forall a. Monoid a => a
mempty
    , fun_id' :: LIdP GhcRn
Ghc.fun_id' = forall a an. a -> LocatedAn an a
Ghc.noLocA' Name
whereBindName
    , fun_matches' :: MatchGroup GhcRn (LHsExpr GhcRn)
Ghc.fun_matches' =
        Ghc.MG
#if MIN_VERSION_ghc(9,6,0)
          { Ghc.mg_ext = Ghc.Generated
#else
          { mg_ext :: XMG GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
Ghc.mg_ext = NoExtField
Ghc.NoExtField
          , mg_origin :: Origin
Ghc.mg_origin = Origin
Ghc.Generated
#endif
          , mg_alts :: XRec GhcRn [LMatch GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
Ghc.mg_alts = forall a an. a -> LocatedAn an a
Ghc.noLocA'
            [forall a an. a -> LocatedAn an a
Ghc.noLocA' Ghc.Match
              { m_ext :: XCMatch GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
Ghc.m_ext = forall a. EpAnn a
Ghc.emptyEpAnn
              , m_ctxt :: HsMatchContext (NoGhcTc GhcRn)
Ghc.m_ctxt = Ghc.FunRhs
                  { mc_fun :: LIdP GhcRn
Ghc.mc_fun = forall a an. a -> LocatedAn an a
Ghc.noLocA' Name
whereBindName
                  , mc_fixity :: LexicalFixity
Ghc.mc_fixity = LexicalFixity
Ghc.Prefix
                  , mc_strictness :: SrcStrictness
Ghc.mc_strictness = SrcStrictness
Ghc.SrcStrict
                  }
              , m_pats :: [LPat GhcRn]
Ghc.m_pats = []
              , m_grhss :: GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
Ghc.m_grhss = Ghc.GRHSs
                  { grhssExt :: XCGRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
Ghc.grhssExt = EpAnnComments
Ghc.emptyComments'
                  , grhssGRHSs :: [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
Ghc.grhssGRHSs =
                    [
#if MIN_VERSION_ghc(9,4,0)
                      Ghc.noLocA $ Ghc.GRHS
#else
                      forall e. e -> Located e
Ghc.noLoc forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS
#endif
                        forall a. EpAnn a
Ghc.emptyEpAnn
                        []
                        LHsExpr GhcRn
whereBindExpr
                    ]
                  , grhssLocalBinds :: HsLocalBinds GhcRn
Ghc.grhssLocalBinds = forall a. a -> a
Ghc.noLoc' forall a b. (a -> b) -> a -> b
$
                      forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
Ghc.EmptyLocalBinds NoExtField
Ghc.NoExtField
                  }
              }
            ]
          }
    }

-- | Add a where bind for the new value of the IP, then add let bindings to the
-- front of each GRHS to set the new value of the IP in that scope.
modifyMatch
  :: Propagation
  -> Ghc.LHsExpr Ghc.GhcRn
  -> DebugNames
  -> Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
  -> StateT (S.Set Ghc.Name) Ghc.TcM (Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn))
modifyMatch :: Propagation
-> LHsExpr GhcRn
-> DebugNames
-> Match GhcRn (LHsExpr GhcRn)
-> StateT
     (Set Name)
     (IOEnv (Env TcGblEnv TcLclEnv))
     (Match GhcRn (LHsExpr GhcRn))
modifyMatch Propagation
prop LHsExpr GhcRn
whereBindExpr DebugNames
debugNames Match GhcRn (LHsExpr GhcRn)
match = do
  Name
whereBindName <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcM Name
mkWhereBindName

  Set Name
visitedNames <- forall (m :: * -> *) s. Monad m => StateT s m s
get

  -- only update the where bindings that don't have Debug
  -- predicates, those that do will be addressed via recursion.
  -- It is also necesarry to descend into potential recursive wheres
  -- but the recursion needs to stop if a known name is found.
  let visitedBinding :: Ghc.HsBind Ghc.GhcRn -> Bool
      visitedBinding :: HsBindLR GhcRn GhcRn -> Bool
visitedBinding Ghc.FunBind{ fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
Ghc.fun_id = Ghc.L SrcSpanAnn' (EpAnn NameAnn)
_ Name
funName }
        = forall a. Ord a => a -> Set a -> Bool
S.member Name
funName Set Name
visitedNames
      visitedBinding HsBindLR GhcRn GhcRn
_ = Bool
False
      -- Do not instrument let bindings in view patterns.
      isViewPat :: Ghc.Pat Ghc.GhcRn -> Bool
      isViewPat :: Pat GhcRn -> Bool
isViewPat Ghc.ViewPat{} = Bool
True
      isViewPat Pat GhcRn
_ = Bool
False

      -- recurse the entire match to add let bindings to all where clauses,
      -- including those belonging to let-bound terms at any nesting depth.
      -- Bindings must be added to let statements in do-blocks as well.
      match' :: Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match'@Ghc.Match
        { m_grhss :: forall p body. Match p body -> GRHSs p body
Ghc.m_grhss =
            grhs :: GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhs@Ghc.GRHSs
              { grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
Ghc.grhssLocalBinds =
#if MIN_VERSION_ghc(9,2,0)
                  HsLocalBinds GhcRn
whereBinds
#else
                  Ghc.L whereLoc whereBinds
#endif
              , grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
Ghc.grhssGRHSs = [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
grhsList
              }
        } = GenericQ Bool -> GenericT -> GenericT
Syb.everywhereBut
              (forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
Syb.mkQ Bool
False HsBindLR GhcRn GhcRn -> Bool
visitedBinding forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`Syb.extQ` Pat GhcRn -> Bool
isViewPat) -- stop condition
              (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
Syb.mkT forall a b. (a -> b) -> a -> b
$ Name -> HsBindLR GhcRn GhcRn -> HsBindLR GhcRn GhcRn
updateDebugIpInFunBind Name
whereBindName)
              Match GhcRn (LHsExpr GhcRn)
match

      ipValWhereBind :: LHsBind GhcRn
ipValWhereBind = Name -> LHsExpr GhcRn -> LHsBind GhcRn
mkWhereBinding Name
whereBindName LHsExpr GhcRn
whereBindExpr

      wrappedBind :: (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
wrappedBind = (RecFlag
Ghc.NonRecursive, forall a. a -> Bag a
Ghc.unitBag LHsBind GhcRn
ipValWhereBind)

      -- NOINLINE pragma. We don't want the where binding to ever be inlined
      -- because then it would generate a different ID.
      noInlineSig :: Ghc.LSig Ghc.GhcRn
      noInlineSig :: LSig GhcRn
noInlineSig = forall a an. a -> LocatedAn an a
Ghc.noLocA' forall a b. (a -> b) -> a -> b
$
        forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
Ghc.InlineSig
          forall a. EpAnn a
Ghc.emptyEpAnn
          (forall a an. a -> LocatedAn an a
Ghc.noLocA' Name
whereBindName)
          InlinePragma
Ghc.neverInlinePragma

      -- Type sig for 'Maybe DebugContext'
      -- Without an explicit signature for the where binding,
      -- -XNoMonomorphismRestriction causes it to be inlined.
      whereBindSig :: Ghc.LSig Ghc.GhcRn
      whereBindSig :: LSig GhcRn
whereBindSig = forall a an. a -> LocatedAn an a
Ghc.noLocA' forall a b. (a -> b) -> a -> b
$
        forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
Ghc.TypeSig
          forall a. EpAnn a
Ghc.emptyEpAnn
          [forall a an. a -> LocatedAn an a
Ghc.noLocA' Name
whereBindName] forall a b. (a -> b) -> a -> b
$
            forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
Ghc.HsWC [] forall a b. (a -> b) -> a -> b
$
              LHsType GhcRn -> LHsSigType GhcRn
Ghc.HsSig' forall a b. (a -> b) -> a -> b
$
                forall a an. a -> LocatedAn an a
Ghc.noLocA' forall a b. (a -> b) -> a -> b
$
                  forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy NoExtField
Ghc.NoExtField
                    (forall a an. a -> LocatedAn an a
Ghc.noLocA' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
Ghc.HsTyVar forall a. EpAnn a
Ghc.emptyEpAnn PromotionFlag
Ghc.NotPromoted
                      forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
Ghc.noLocA' Name
Ghc.maybeTyConName)
                    (forall a an. a -> LocatedAn an a
Ghc.noLocA' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
Ghc.HsTyVar forall a. EpAnn a
Ghc.emptyEpAnn PromotionFlag
Ghc.NotPromoted forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       forall a an. a -> LocatedAn an a
Ghc.noLocA' forall a b. (a -> b) -> a -> b
$ DebugNames -> Name
debugContextName DebugNames
debugNames
                    )

      -- add the generated bind to the function's where clause
      whereBinds' :: HsLocalBinds GhcRn
whereBinds' =
        case HsLocalBinds GhcRn
whereBinds of
          Ghc.EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
_ ->
            forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
Ghc.HsValBinds forall a. EpAnn a
Ghc.emptyEpAnn
              (forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
Ghc.XValBindsLR
                (forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
Ghc.NValBinds [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
wrappedBind] [LSig GhcRn
noInlineSig, LSig GhcRn
whereBindSig])
              )

          Ghc.HsValBinds XHsValBinds GhcRn GhcRn
x (Ghc.XValBindsLR (Ghc.NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs)) ->
             forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
Ghc.HsValBinds XHsValBinds GhcRn GhcRn
x
               (forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
Ghc.XValBindsLR
                 (forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
Ghc.NValBinds
                   ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
wrappedBind forall a. a -> [a] -> [a]
: [(RecFlag, LHsBinds GhcRn)]
binds)
                   (LSig GhcRn
noInlineSig forall a. a -> [a] -> [a]
: LSig GhcRn
whereBindSig forall a. a -> [a] -> [a]
: [LSig GhcRn]
sigs)
                 )
               )

          HsLocalBinds GhcRn
_ -> HsLocalBinds GhcRn
whereBinds

  forall (f :: * -> *) a. Applicative f => a -> f a
pure Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match'{ m_grhss :: GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
Ghc.m_grhss = GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhs
                 { grhssLocalBinds :: HsLocalBinds GhcRn
Ghc.grhssLocalBinds =
#if MIN_VERSION_ghc(9,2,0)
                     HsLocalBinds GhcRn
whereBinds'
#else
                     Ghc.L whereLoc whereBinds'
#endif
                 , grhssGRHSs :: [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
Ghc.grhssGRHSs =
                     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( Name -> GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
updateDebugIPInGRHS Name
whereBindName
                     -- Don't emit entry event if propagation is Mute
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Propagation
prop forall a. Eq a => a -> a -> Bool
== Propagation
Mute
                               then forall a. a -> a
id
                               else Name -> GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
emitEntryEvent (DebugNames -> Name
entryName DebugNames
debugNames)
                          )
                       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
grhsList
                 }
             }

-- | Targets function bindings that are known to not have a debug constraint
-- and then updates the definitions of those functions to add the special let
-- statement referencing the where binding.
updateDebugIpInFunBind
  :: Ghc.Name
  -> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn
  -> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn
updateDebugIpInFunBind :: Name -> HsBindLR GhcRn GhcRn -> HsBindLR GhcRn GhcRn
updateDebugIpInFunBind Name
whereVarName
    b :: HsBindLR GhcRn GhcRn
b@Ghc.FunBind{ fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
Ghc.fun_matches = m :: MatchGroup GhcRn (LHsExpr GhcRn)
m@Ghc.MG{ mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
Ghc.mg_alts = XRec GhcRn [LMatch GhcRn (LHsExpr GhcRn)]
alts } }
  = HsBindLR GhcRn GhcRn
b { fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
Ghc.fun_matches =
        MatchGroup GhcRn (LHsExpr GhcRn)
m { mg_alts :: XRec GhcRn [LMatch GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
Ghc.mg_alts = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
updateMatch XRec GhcRn [LMatch GhcRn (LHsExpr GhcRn)]
alts }
      }
  where
    updateMatch :: Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
updateMatch mtch :: Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
mtch@Ghc.Match{m_grhss :: forall p body. Match p body -> GRHSs p body
Ghc.m_grhss = g :: GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
g@Ghc.GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
Ghc.grhssGRHSs = [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
grhss}}
      = Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
mtch{m_grhss :: GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
Ghc.m_grhss =
               GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
g{grhssGRHSs :: [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
Ghc.grhssGRHSs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
updateDebugIPInGRHS Name
whereVarName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
grhss }
            }
#if !(MIN_VERSION_ghc(9,0,0))
    updateMatch x = x
#endif
updateDebugIpInFunBind Name
whereVarName
    b :: HsBindLR GhcRn GhcRn
b@Ghc.PatBind{ pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
Ghc.pat_rhs = g :: GRHSs GhcRn (LHsExpr GhcRn)
g@Ghc.GRHSs{ grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
Ghc.grhssGRHSs = [LGRHS GhcRn (LHsExpr GhcRn)]
grhss } }
  = HsBindLR GhcRn GhcRn
b { pat_rhs :: GRHSs GhcRn (LHsExpr GhcRn)
Ghc.pat_rhs =
          GRHSs GhcRn (LHsExpr GhcRn)
g{ grhssGRHSs :: [LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
Ghc.grhssGRHSs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
updateDebugIPInGRHS Name
whereVarName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LGRHS GhcRn (LHsExpr GhcRn)]
grhss }
      }
updateDebugIpInFunBind Name
_ HsBindLR GhcRn GhcRn
b = HsBindLR GhcRn GhcRn
b

-- | Produce the contents of the where binding that contains the new debug IP
-- value, generated by creating a new ID and pairing it with the old one.
-- The ID is randomly generated. Could instead have a global ID sequence but
-- the random ID has the advantage that a program can be run multiple times
-- using the same log file and the traces won't conflict.
mkNewIpExpr
  :: Ghc.SrcSpan
  -> Either FunName UserKey
  -> Propagation
  -> Ghc.TcM (Ghc.LHsExpr Ghc.GhcRn)
mkNewIpExpr :: SrcSpan
-> Either FunName FunName -> Propagation -> TcM (LHsExpr GhcRn)
mkNewIpExpr SrcSpan
srcSpan Either FunName FunName
newKey Propagation
newProp = do
  let mDefSite :: Maybe SrcCodeLoc
mDefSite = case SrcSpan -> SrcLoc
Ghc.srcSpanStart SrcSpan
srcSpan of
                   Ghc.RealSrcLoc' RealSrcLoc
loc ->
                     forall a. a -> Maybe a
Just SrcCodeLoc
                       { srcModule :: FunName
srcModule = FastString -> FunName
Ghc.unpackFS forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> FastString
Ghc.srcLocFile RealSrcLoc
loc
                       , srcLine :: SrcLine
srcLine = RealSrcLoc -> SrcLine
Ghc.srcLocLine RealSrcLoc
loc
                       , srcCol :: SrcLine
srcCol = RealSrcLoc -> SrcLine
Ghc.srcLocCol RealSrcLoc
loc
                       }
                   SrcLoc
_ -> forall a. Maybe a
Nothing
  Right GenLocated SrcSpanAnnA (HsExpr GhcPs)
exprPs
    <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Origin -> SrcSpan -> Exp -> Either SDoc (LHsExpr GhcPs)
Ghc.convertToHsExpr Origin
Ghc.Generated SrcSpan
Ghc.noSrcSpan)
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
     forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Quasi m => Q a -> m a
TH.runQ [| noinline $! Just $! mkNewDebugContext mDefSite newKey newProp ?_debug_ip |]

  (GenLocated SrcSpanAnnA (HsExpr GhcRn)
exprRn, NameSet
_) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
Ghc.rnLExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
exprPs

  forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcRn)
exprRn

-- | Build a new debug context from the previous state. Uses unsafe IO
-- to generate a random ID associated with a particular function invocation
mkNewDebugContext
  :: Maybe DefinitionSite -- ^ Definition site of current function
  -> Either FunName UserKey -- ^ Name of the function or a key supplied by the user
  -> Propagation -- ^ propagation strategy for new context
  -> Maybe DebugContext
  -> DebugContext
mkNewDebugContext :: Maybe SrcCodeLoc
-> Either FunName FunName
-> Propagation
-> Maybe DebugContext
-> DebugContext
mkNewDebugContext Maybe SrcCodeLoc
mDefSite Either FunName FunName
newKey Propagation
newProp Maybe DebugContext
mPrevCtx =
  case (Maybe DebugContext
mPrevCtx, Either FunName FunName
newKey) of
    -- If override key matches with previous tag, keep the id
    (Just DebugContext
prevCtx, Right FunName
userKey)
      | DebugTag -> Either FunName FunName
debugKey (DebugContext -> DebugTag
currentTag DebugContext
prevCtx) forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right FunName
userKey
      -> DebugContext
prevCtx
           { propagation :: Propagation
propagation = Maybe Propagation -> Propagation
getNextProp (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DebugContext -> Propagation
propagation DebugContext
prevCtx) }
    (Maybe DebugContext, Either FunName FunName)
_ -> forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
      Word
newId <- forall a (m :: * -> *). (Random a, MonadIO m) => m a
Rand.randomIO :: IO Word
      let newTag :: DebugTag
newTag = DT
            { invocationId :: Word
invocationId = Word
newId
            , debugKey :: Either FunName FunName
debugKey = Either FunName FunName
newKey
            }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        DC { previousTag :: Maybe DebugTag
previousTag = DebugContext -> DebugTag
currentTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DebugContext
mPrevCtx
           , currentTag :: DebugTag
currentTag = DebugTag
newTag
           , propagation :: Propagation
propagation = Maybe Propagation -> Propagation
getNextProp (DebugContext -> Propagation
propagation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DebugContext
mPrevCtx)
           , definitionSite :: Maybe SrcCodeLoc
definitionSite = Maybe SrcCodeLoc
mDefSite
           }
  where
    getNextProp :: Maybe Propagation -> Propagation
getNextProp Maybe Propagation
Nothing = Propagation
newProp
    getNextProp (Just Propagation
prev) =
      case (Propagation
prev, Propagation
newProp) of
        (Propagation
Mute, Propagation
_) -> Propagation
Mute
        (Propagation
_, Propagation
Mute) -> Propagation
Mute
        (Propagation
Deep, Propagation
_) -> Propagation
Deep
        (Propagation, Propagation)
_    -> Propagation
newProp

-- | Wraps an expression with the 'entry' function.
emitEntryEvent
  :: Ghc.Name
  -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
  -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
emitEntryEvent :: Name -> GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
emitEntryEvent Name
emitEntryName (Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x [GuardLStmt GhcRn]
guards LHsExpr GhcRn
body) =
  forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x [GuardLStmt GhcRn]
guards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a an. a -> LocatedAn an a
Ghc.noLocA' forall a b. (a -> b) -> a -> b
$
    forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
Ghc.HsApp forall a. EpAnn a
Ghc.emptyEpAnn
      (forall a an. a -> LocatedAn an a
Ghc.noLocA' forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         forall p. XVar p -> LIdP p -> HsExpr p
Ghc.HsVar NoExtField
Ghc.NoExtField forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
Ghc.noLocA' Name
emitEntryName
      )
      LHsExpr GhcRn
body
#if !(MIN_VERSION_ghc(9,0,0))
emitEntryEvent _ x = x
#endif

-- | Given the name of the variable to assign to the debug IP, create a let
-- expression as a guard statement that updates the IP in that scope.
updateDebugIPInGRHS
  :: Ghc.Name
  -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
  -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
updateDebugIPInGRHS :: Name -> GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
updateDebugIPInGRHS Name
whereBindName (Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x [GuardLStmt GhcRn]
guards LHsExpr GhcRn
body)
  = forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x (LocatedAn
  AnnListItem
  (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
ipUpdateGuard forall a. a -> [a] -> [a]
: [GuardLStmt GhcRn]
guards) LHsExpr GhcRn
body
  where
    ipUpdateGuard :: LocatedAn
  AnnListItem
  (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
ipUpdateGuard =
      forall a an. a -> LocatedAn an a
Ghc.noLocA' forall a b. (a -> b) -> a -> b
$
        forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
Ghc.LetStmt forall a. EpAnn a
Ghc.emptyEpAnn forall a b. (a -> b) -> a -> b
$
          forall a. a -> a
Ghc.noLoc' forall a b. (a -> b) -> a -> b
$
            forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
Ghc.HsIPBinds forall a. EpAnn a
Ghc.emptyEpAnn forall a b. (a -> b) -> a -> b
$
              forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
Ghc.IPBinds NoExtField
Ghc.NoExtField
                [ forall a an. a -> LocatedAn an a
Ghc.noLocA' forall a b. (a -> b) -> a -> b
$ forall id.
XCIPBind id
-> Either (XRec id HsIPName) (IdP id) -> LHsExpr id -> IPBind id
Ghc.IPBind
#if MIN_VERSION_ghc(9,4,0)
                    Ghc.NoExtField
                    (Ghc.noLocA' $ Ghc.HsIPName "_debug_ip")
#else
                    forall a. EpAnn a
Ghc.emptyEpAnn
                    (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
Ghc.noLoc forall a b. (a -> b) -> a -> b
$ FastString -> HsIPName
Ghc.HsIPName FastString
"_debug_ip")
#endif
                    (forall a an. a -> LocatedAn an a
Ghc.noLocA' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XVar p -> LIdP p -> HsExpr p
Ghc.HsVar NoExtField
Ghc.NoExtField
                      forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
Ghc.noLocA' Name
whereBindName
                    )
                ]
#if !(MIN_VERSION_ghc(9,0,0))
updateDebugIPInGRHS _ x = x
#endif

-- ppr :: Ghc.Outputable a => a -> String
-- ppr = Ghc.showSDocUnsafe . Ghc.ppr