{-# 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) TcM) (NHsValBindsLR GhcRn)
modifyValBinds DebugNames
debugNames Map Name (Maybe FastString, Propagation)
nameMap (Ghc.NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs) = do
  [(RecFlag, LHsBinds GhcRn)]
binds' <-
    (((RecFlag, LHsBinds GhcRn)
 -> WriterT
      (Set Name) (StateT (Set Name) TcM) (RecFlag, LHsBinds GhcRn))
-> [(RecFlag, LHsBinds GhcRn)]
-> WriterT
     (Set Name) (StateT (Set Name) TcM) [(RecFlag, LHsBinds GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((RecFlag, LHsBinds GhcRn)
  -> WriterT
       (Set Name) (StateT (Set Name) TcM) (RecFlag, LHsBinds GhcRn))
 -> [(RecFlag, LHsBinds GhcRn)]
 -> WriterT
      (Set Name) (StateT (Set Name) TcM) [(RecFlag, LHsBinds GhcRn)])
-> ((LHsBinds GhcRn
     -> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn))
    -> (RecFlag, LHsBinds GhcRn)
    -> WriterT
         (Set Name) (StateT (Set Name) TcM) (RecFlag, LHsBinds GhcRn))
-> (LHsBinds GhcRn
    -> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn))
-> [(RecFlag, LHsBinds GhcRn)]
-> WriterT
     (Set Name) (StateT (Set Name) TcM) [(RecFlag, LHsBinds GhcRn)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsBinds GhcRn
 -> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn))
-> (RecFlag, LHsBinds GhcRn)
-> WriterT
     (Set Name) (StateT (Set Name) TcM) (RecFlag, LHsBinds GhcRn)
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) TcM) (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames)
      [(RecFlag, LHsBinds GhcRn)]
binds
  StateT (Set Name) TcM ()
-> WriterT (Set Name) (StateT (Set Name) TcM) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Set Name) TcM ()
 -> WriterT (Set Name) (StateT (Set Name) TcM) ())
-> StateT (Set Name) TcM ()
-> WriterT (Set Name) (StateT (Set Name) TcM) ()
forall a b. (a -> b) -> a -> b
$ (Set Name -> Set Name) -> StateT (Set Name) TcM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.union (Set Name -> Set Name -> Set Name)
-> Set Name -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Map Name (Maybe FastString, Propagation) -> Set Name
forall k a. Map k a -> Set k
M.keysSet Map Name (Maybe FastString, Propagation)
nameMap)
  NHsValBindsLR GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (NHsValBindsLR GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NHsValBindsLR GhcRn
 -> WriterT
      (Set Name) (StateT (Set Name) TcM) (NHsValBindsLR GhcRn))
-> NHsValBindsLR GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (NHsValBindsLR GhcRn)
forall a b. (a -> b) -> a -> b
$ [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR GhcRn
forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
Ghc.NValBinds [(RecFlag, LHsBinds 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) TcM) (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
  LHsBinds GhcRn
newMeths <- Map Name (Maybe FastString, Propagation)
-> DebugNames
-> LHsBinds GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames LHsBinds GhcRn
meths
  TyClDecl GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (TyClDecl GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyClDecl GhcRn
cd { tcdMeths :: LHsBinds GhcRn
Ghc.tcdMeths = LHsBinds GhcRn
newMeths }
modifyTyClDecl DebugNames
_ Map Name (Maybe FastString, Propagation)
_ TyClDecl GhcRn
x = TyClDecl GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (TyClDecl GhcRn)
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) TcM) (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
  LHsBinds GhcRn
newBinds <- Map Name (Maybe FastString, Propagation)
-> DebugNames
-> LHsBinds GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames LHsBinds GhcRn
binds
  ClsInstDecl GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (ClsInstDecl GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClsInstDecl GhcRn
inst { cid_binds :: LHsBinds GhcRn
Ghc.cid_binds = LHsBinds GhcRn
newBinds }
#if !(MIN_VERSION_ghc(9,0,0))
modifyClsInstDecl DebugNames
_ Map Name (Maybe FastString, Propagation)
_ ClsInstDecl GhcRn
x = ClsInstDecl GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (ClsInstDecl GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClsInstDecl GhcRn
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) TcM) (LHsBinds GhcRn)
modifyBinds Map Name (Maybe FastString, Propagation)
nameMap DebugNames
debugNames =
  ((GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
 -> WriterT
      (Set Name)
      (StateT (Set Name) TcM)
      (GenLocated SrcSpan (HsBindLR GhcRn GhcRn)))
-> LHsBinds GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
  -> WriterT
       (Set Name)
       (StateT (Set Name) TcM)
       (GenLocated SrcSpan (HsBindLR GhcRn GhcRn)))
 -> LHsBinds GhcRn
 -> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn))
-> ((HsBindLR GhcRn GhcRn
     -> WriterT
          (Set Name) (StateT (Set Name) TcM) (HsBindLR GhcRn GhcRn))
    -> GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
    -> WriterT
         (Set Name)
         (StateT (Set Name) TcM)
         (GenLocated SrcSpan (HsBindLR GhcRn GhcRn)))
-> (HsBindLR GhcRn GhcRn
    -> WriterT
         (Set Name) (StateT (Set Name) TcM) (HsBindLR GhcRn GhcRn))
-> LHsBinds GhcRn
-> WriterT (Set Name) (StateT (Set Name) TcM) (LHsBinds GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsBindLR GhcRn GhcRn
 -> WriterT
      (Set Name) (StateT (Set Name) TcM) (HsBindLR GhcRn GhcRn))
-> GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
-> WriterT
     (Set Name)
     (StateT (Set Name) TcM)
     (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
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) TcM) (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) TcM) (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 -> Located (IdP idL)
Ghc.fun_id = Ghc.L' loc name
                  , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
Ghc.fun_matches = mg :: MatchGroup GhcRn (LHsExpr GhcRn)
mg@(Ghc.MG XMG GhcRn (LHsExpr GhcRn)
_ Located [LMatch GhcRn (LHsExpr GhcRn)]
alts Origin
_) }
    | Just (Maybe FastString
mUserKey, Propagation
prop) <- Name
-> Map Name (Maybe FastString, Propagation)
-> Maybe (Maybe FastString, Propagation)
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 String String
key = case Maybe FastString
mUserKey of
                  Maybe FastString
Nothing -> String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. NamedThing a => a -> String
Ghc.getOccString Name
name
                  Just FastString
k -> String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ FastString -> String
Ghc.unpackFS FastString
k

      LHsExpr GhcRn
whereBindExpr <- StateT (Set Name) TcM (LHsExpr GhcRn)
-> WriterT (Set Name) (StateT (Set Name) TcM) (LHsExpr GhcRn)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Set Name) TcM (LHsExpr GhcRn)
 -> WriterT (Set Name) (StateT (Set Name) TcM) (LHsExpr GhcRn))
-> (IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
    -> StateT (Set Name) TcM (LHsExpr GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
-> WriterT (Set Name) (StateT (Set Name) TcM) (LHsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
-> StateT (Set Name) TcM (LHsExpr GhcRn)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
 -> WriterT (Set Name) (StateT (Set Name) TcM) (LHsExpr GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
-> WriterT (Set Name) (StateT (Set Name) TcM) (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Either String String
-> Propagation
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
mkNewIpExpr SrcSpan
loc Either String String
key Propagation
prop

      Located [LMatch GhcRn (LHsExpr GhcRn)]
newAlts <- StateT (Set Name) TcM (Located [LMatch GhcRn (LHsExpr GhcRn)])
-> WriterT
     (Set Name)
     (StateT (Set Name) TcM)
     (Located [LMatch GhcRn (LHsExpr GhcRn)])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Set Name) TcM (Located [LMatch GhcRn (LHsExpr GhcRn)])
 -> WriterT
      (Set Name)
      (StateT (Set Name) TcM)
      (Located [LMatch GhcRn (LHsExpr GhcRn)]))
-> StateT (Set Name) TcM (Located [LMatch GhcRn (LHsExpr GhcRn)])
-> WriterT
     (Set Name)
     (StateT (Set Name) TcM)
     (Located [LMatch GhcRn (LHsExpr GhcRn)])
forall a b. (a -> b) -> a -> b
$
        (([LMatch GhcRn (LHsExpr GhcRn)]
 -> StateT (Set Name) TcM [LMatch GhcRn (LHsExpr GhcRn)])
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
-> StateT (Set Name) TcM (Located [LMatch GhcRn (LHsExpr GhcRn)])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([LMatch GhcRn (LHsExpr GhcRn)]
  -> StateT (Set Name) TcM [LMatch GhcRn (LHsExpr GhcRn)])
 -> Located [LMatch GhcRn (LHsExpr GhcRn)]
 -> StateT (Set Name) TcM (Located [LMatch GhcRn (LHsExpr GhcRn)]))
-> ((Match GhcRn (LHsExpr GhcRn)
     -> StateT (Set Name) TcM (Match GhcRn (LHsExpr GhcRn)))
    -> [LMatch GhcRn (LHsExpr GhcRn)]
    -> StateT (Set Name) TcM [LMatch GhcRn (LHsExpr GhcRn)])
-> (Match GhcRn (LHsExpr GhcRn)
    -> StateT (Set Name) TcM (Match GhcRn (LHsExpr GhcRn)))
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
-> StateT (Set Name) TcM (Located [LMatch GhcRn (LHsExpr GhcRn)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LMatch GhcRn (LHsExpr GhcRn)
 -> StateT (Set Name) TcM (LMatch GhcRn (LHsExpr GhcRn)))
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> StateT (Set Name) TcM [LMatch GhcRn (LHsExpr GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((LMatch GhcRn (LHsExpr GhcRn)
  -> StateT (Set Name) TcM (LMatch GhcRn (LHsExpr GhcRn)))
 -> [LMatch GhcRn (LHsExpr GhcRn)]
 -> StateT (Set Name) TcM [LMatch GhcRn (LHsExpr GhcRn)])
-> ((Match GhcRn (LHsExpr GhcRn)
     -> StateT (Set Name) TcM (Match GhcRn (LHsExpr GhcRn)))
    -> LMatch GhcRn (LHsExpr GhcRn)
    -> StateT (Set Name) TcM (LMatch GhcRn (LHsExpr GhcRn)))
-> (Match GhcRn (LHsExpr GhcRn)
    -> StateT (Set Name) TcM (Match GhcRn (LHsExpr GhcRn)))
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> StateT (Set Name) TcM [LMatch GhcRn (LHsExpr GhcRn)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match GhcRn (LHsExpr GhcRn)
 -> StateT (Set Name) TcM (Match GhcRn (LHsExpr GhcRn)))
-> LMatch GhcRn (LHsExpr GhcRn)
-> StateT (Set Name) TcM (LMatch GhcRn (LHsExpr GhcRn))
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) TcM (Match GhcRn (LHsExpr GhcRn))
modifyMatch Propagation
prop LHsExpr GhcRn
whereBindExpr DebugNames
debugNames)
          Located [LMatch GhcRn (LHsExpr GhcRn)]
alts

      HsBindLR GhcRn GhcRn
-> WriterT
     (Set Name) (StateT (Set Name) TcM) (HsBindLR GhcRn GhcRn)
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 :: Located [LMatch GhcRn (LHsExpr GhcRn)]
Ghc.mg_alts = Located [LMatch GhcRn (LHsExpr 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
_ (Located (IdP GhcRn) -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc -> SrcSpanLess (Located Name)
name)
            | Name -> Map Name (Maybe FastString, Propagation) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member SrcSpanLess (Located Name)
Name
name Map Name (Maybe FastString, Propagation)
nameMap -> Name -> Set Name
forall a. a -> Set a
S.singleton SrcSpanLess (Located Name)
Name
name
          Ghc.AsPat XAsPat GhcRn
_ (Located (IdP GhcRn) -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc -> SrcSpanLess (Located Name)
name) LPat GhcRn
_
            | Name -> Map Name (Maybe FastString, Propagation) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member SrcSpanLess (Located Name)
Name
name Map Name (Maybe FastString, Propagation)
nameMap -> Name -> Set Name
forall a. a -> Set a
S.singleton SrcSpanLess (Located Name)
Name
name
          Pat GhcRn
_ -> Set Name
forall a. Monoid a => a
mempty
        vars :: Set Name
vars = (Set Name -> Set Name -> Set Name)
-> GenericQ (Set Name) -> Located (Pat GhcRn) -> Set Name
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
Syb.everything Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
(<>) (Set Name -> (Pat GhcRn -> Set Name) -> a -> Set Name
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
Syb.mkQ Set Name
forall a. Monoid a => a
mempty Pat GhcRn -> Set Name
collectName) LPat GhcRn
Located (Pat GhcRn)
pat
    Set Name -> WriterT (Set Name) (StateT (Set Name) TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell Set Name
vars
    HsBindLR GhcRn GhcRn
-> WriterT
     (Set Name) (StateT (Set Name) TcM) (HsBindLR GhcRn GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsBindLR GhcRn GhcRn
bnd
modifyBinding Map Name (Maybe FastString, Propagation)
_ DebugNames
_ HsBindLR GhcRn GhcRn
bnd = HsBindLR GhcRn GhcRn
-> WriterT
     (Set Name) (StateT (Set Name) TcM) (HsBindLR GhcRn GhcRn)
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 <- IOEnv (Env TcGblEnv TcLclEnv) Unique
forall (m :: * -> *). MonadUnique m => m Unique
Ghc.getUniqueM
  Name -> TcM Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> TcM Name) -> Name -> TcM Name
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 -> GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
mkWhereBinding Name
whereBindName LHsExpr GhcRn
whereBindExpr =
  HsBindLR GhcRn GhcRn -> GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
forall a. a -> Located a
Ghc.noLocA' FunBind' :: XFunBind GhcRn GhcRn
-> Located (IdP GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> HsBindLR GhcRn GhcRn
Ghc.FunBind'
    { fun_ext' :: XFunBind GhcRn GhcRn
Ghc.fun_ext' = XFunBind GhcRn GhcRn
forall a. Monoid a => a
mempty
    , fun_id' :: Located (IdP GhcRn)
Ghc.fun_id' = Name -> Located Name
forall a. a -> Located a
Ghc.noLocA' Name
whereBindName
    , fun_matches' :: MatchGroup GhcRn (LHsExpr GhcRn)
Ghc.fun_matches' =
        MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
Ghc.MG
          { mg_ext :: XMG GhcRn (LHsExpr GhcRn)
Ghc.mg_ext = NoExtField
XMG GhcRn (LHsExpr GhcRn)
Ghc.NoExtField
          , mg_alts :: Located [LMatch GhcRn (LHsExpr GhcRn)]
Ghc.mg_alts = [LMatch GhcRn (LHsExpr GhcRn)]
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
forall a. a -> Located a
Ghc.noLocA'
            [Match GhcRn (LHsExpr GhcRn) -> LMatch GhcRn (LHsExpr GhcRn)
forall a. a -> Located a
Ghc.noLocA' Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Ghc.Match
              { m_ext :: XCMatch GhcRn (LHsExpr GhcRn)
Ghc.m_ext = NoExtField
XCMatch GhcRn (LHsExpr GhcRn)
Ghc.emptyEpAnn
              , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcRn))
Ghc.m_ctxt = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
Ghc.FunRhs
                  { mc_fun :: Located Name
Ghc.mc_fun = Name -> Located Name
forall a. a -> Located 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 (LHsExpr GhcRn)
Ghc.m_grhss = GRHSs :: forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
Ghc.GRHSs
                  { grhssExt :: XCGRHSs GhcRn (LHsExpr GhcRn)
Ghc.grhssExt = NoExtField
XCGRHSs GhcRn (LHsExpr GhcRn)
Ghc.emptyComments'
                  , grhssGRHSs :: [LGRHS GhcRn (LHsExpr GhcRn)]
Ghc.grhssGRHSs =
                    [ SrcSpanLess (LGRHS GhcRn (LHsExpr GhcRn))
-> LGRHS GhcRn (LHsExpr GhcRn)
forall a. HasSrcSpan a => SrcSpanLess a -> a
Ghc.noLoc (SrcSpanLess (LGRHS GhcRn (LHsExpr GhcRn))
 -> LGRHS GhcRn (LHsExpr GhcRn))
-> SrcSpanLess (LGRHS GhcRn (LHsExpr GhcRn))
-> LGRHS GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcRn (LHsExpr GhcRn)
-> [GuardLStmt GhcRn]
-> LHsExpr GhcRn
-> GRHS GhcRn (LHsExpr GhcRn)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS
                        NoExtField
XCGRHS GhcRn (LHsExpr GhcRn)
Ghc.emptyEpAnn
                        []
                        LHsExpr GhcRn
whereBindExpr
                    ]
                  , grhssLocalBinds :: LHsLocalBinds GhcRn
Ghc.grhssLocalBinds = HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn
forall a. a -> Located a
Ghc.noLoc' (HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn)
-> HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn
forall a b. (a -> b) -> a -> b
$
                      XEmptyLocalBinds GhcRn GhcRn -> HsLocalBindsLR GhcRn GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
Ghc.EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcRn GhcRn
Ghc.NoExtField
                  }
              }
            ]
          , mg_origin :: Origin
Ghc.mg_origin = Origin
Ghc.Generated
          }
    }

-- | 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) TcM (Match GhcRn (LHsExpr GhcRn))
modifyMatch Propagation
prop LHsExpr GhcRn
whereBindExpr DebugNames
debugNames Match GhcRn (LHsExpr GhcRn)
match = do
  Name
whereBindName <- TcM Name -> StateT (Set Name) TcM Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcM Name
mkWhereBindName

  Set Name
visitedNames <- StateT (Set Name) TcM (Set Name)
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 -> Located (IdP idL)
Ghc.fun_id = Ghc.L SrcSpan
_ IdP GhcRn
funName }
        = Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member IdP GhcRn
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 (LHsExpr GhcRn)
match'@Ghc.Match
        { m_grhss :: forall p body. Match p body -> GRHSs p body
Ghc.m_grhss =
            grhs :: GRHSs GhcRn (LHsExpr GhcRn)
grhs@Ghc.GRHSs
              { grhssLocalBinds :: forall p body. GRHSs p body -> LHsLocalBinds p
Ghc.grhssLocalBinds =
#if MIN_VERSION_ghc(9,2,0)
                  whereBinds
#else
                  Ghc.L SrcSpan
whereLoc HsLocalBindsLR GhcRn GhcRn
whereBinds
#endif
              , grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
Ghc.grhssGRHSs = [LGRHS GhcRn (LHsExpr GhcRn)]
grhsList
              }
        } = GenericQ Bool
-> GenericT
-> Match GhcRn (LHsExpr GhcRn)
-> Match GhcRn (LHsExpr GhcRn)
GenericQ Bool -> GenericT -> GenericT
Syb.everywhereBut
              (Bool -> (HsBindLR GhcRn GhcRn -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
Syb.mkQ Bool
False HsBindLR GhcRn GhcRn -> Bool
visitedBinding (a -> Bool) -> (Pat GhcRn -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`Syb.extQ` Pat GhcRn -> Bool
isViewPat) -- stop condition
              ((HsBindLR GhcRn GhcRn -> HsBindLR GhcRn GhcRn) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
Syb.mkT ((HsBindLR GhcRn GhcRn -> HsBindLR GhcRn GhcRn) -> a -> a)
-> (HsBindLR GhcRn GhcRn -> HsBindLR GhcRn GhcRn) -> a -> a
forall a b. (a -> b) -> a -> b
$ Name -> HsBindLR GhcRn GhcRn -> HsBindLR GhcRn GhcRn
updateDebugIpInFunBind Name
whereBindName)
              Match GhcRn (LHsExpr GhcRn)
match

      ipValWhereBind :: GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
ipValWhereBind = Name -> LHsExpr GhcRn -> GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
mkWhereBinding Name
whereBindName LHsExpr GhcRn
whereBindExpr

      wrappedBind :: (RecFlag, LHsBinds GhcRn)
wrappedBind = (RecFlag
Ghc.NonRecursive, GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> LHsBinds GhcRn
forall a. a -> Bag a
Ghc.unitBag GenLocated SrcSpan (HsBindLR GhcRn 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 = Sig GhcRn -> LSig GhcRn
forall a. a -> Located a
Ghc.noLocA' (Sig GhcRn -> LSig GhcRn) -> Sig GhcRn -> LSig GhcRn
forall a b. (a -> b) -> a -> b
$
        XInlineSig GhcRn
-> Located (IdP GhcRn) -> InlinePragma -> Sig GhcRn
forall pass.
XInlineSig pass -> Located (IdP pass) -> InlinePragma -> Sig pass
Ghc.InlineSig
          NoExtField
XInlineSig GhcRn
Ghc.emptyEpAnn
          (Name -> Located Name
forall a. a -> Located 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 = Sig GhcRn -> LSig GhcRn
forall a. a -> Located a
Ghc.noLocA' (Sig GhcRn -> LSig GhcRn) -> Sig GhcRn -> LSig GhcRn
forall a b. (a -> b) -> a -> b
$
        XTypeSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
Ghc.TypeSig
          NoExtField
XTypeSig GhcRn
Ghc.emptyEpAnn
          [Name -> Located Name
forall a. a -> Located a
Ghc.noLocA' Name
whereBindName] (LHsSigWcType GhcRn -> Sig GhcRn)
-> LHsSigWcType GhcRn -> Sig GhcRn
forall a b. (a -> b) -> a -> b
$
            XHsWC GhcRn (HsImplicitBndrs GhcRn (LHsType GhcRn))
-> HsImplicitBndrs GhcRn (LHsType GhcRn) -> LHsSigWcType GhcRn
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
Ghc.HsWC [] (HsImplicitBndrs GhcRn (LHsType GhcRn) -> LHsSigWcType GhcRn)
-> HsImplicitBndrs GhcRn (LHsType GhcRn) -> LHsSigWcType GhcRn
forall a b. (a -> b) -> a -> b
$
              LHsType GhcRn -> HsImplicitBndrs GhcRn (LHsType GhcRn)
Ghc.HsSig' (LHsType GhcRn -> HsImplicitBndrs GhcRn (LHsType GhcRn))
-> LHsType GhcRn -> HsImplicitBndrs GhcRn (LHsType GhcRn)
forall a b. (a -> b) -> a -> b
$
                HsType GhcRn -> LHsType GhcRn
forall a. a -> Located a
Ghc.noLocA' (HsType GhcRn -> LHsType GhcRn) -> HsType GhcRn -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$
                  XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy NoExtField
XAppTy GhcRn
Ghc.NoExtField
                    (HsType GhcRn -> LHsType GhcRn
forall a. a -> Located a
Ghc.noLocA' (HsType GhcRn -> LHsType GhcRn)
-> (Located Name -> HsType GhcRn) -> Located Name -> LHsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcRn
Ghc.emptyEpAnn PromotionFlag
Ghc.NotPromoted
                      (Located Name -> LHsType GhcRn) -> Located Name -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> Located Name
forall a. a -> Located a
Ghc.noLocA' Name
Ghc.maybeTyConName)
                    (HsType GhcRn -> LHsType GhcRn
forall a. a -> Located a
Ghc.noLocA' (HsType GhcRn -> LHsType GhcRn)
-> (Name -> HsType GhcRn) -> Name -> LHsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcRn
Ghc.emptyEpAnn PromotionFlag
Ghc.NotPromoted (Located Name -> HsType GhcRn)
-> (Name -> Located Name) -> Name -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       Name -> Located Name
forall a. a -> Located a
Ghc.noLocA' (Name -> LHsType GhcRn) -> Name -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ DebugNames -> Name
debugContextName DebugNames
debugNames
                    )

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

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

          HsLocalBindsLR GhcRn GhcRn
_ -> HsLocalBindsLR GhcRn GhcRn
whereBinds

  Match GhcRn (LHsExpr GhcRn)
-> StateT (Set Name) TcM (Match GhcRn (LHsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Match GhcRn (LHsExpr GhcRn)
match'{ m_grhss :: GRHSs GhcRn (LHsExpr GhcRn)
Ghc.m_grhss = GRHSs GhcRn (LHsExpr GhcRn)
grhs
                 { grhssLocalBinds :: LHsLocalBinds GhcRn
Ghc.grhssLocalBinds =
#if MIN_VERSION_ghc(9,2,0)
                     whereBinds'
#else
                     SrcSpan -> HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
whereLoc HsLocalBindsLR GhcRn GhcRn
whereBinds'
#endif
                 , grhssGRHSs :: [LGRHS GhcRn (LHsExpr GhcRn)]
Ghc.grhssGRHSs =
                     (GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn))
-> LGRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn)
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
                          (GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn))
-> (GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn))
-> GRHS GhcRn (LHsExpr GhcRn)
-> GRHS GhcRn (LHsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Propagation
prop Propagation -> Propagation -> Bool
forall a. Eq a => a -> a -> Bool
== Propagation
Mute
                               then GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
forall a. a -> a
id
                               else Name -> GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn)
emitEntryEvent (DebugNames -> Name
entryName DebugNames
debugNames)
                          )
                       (LGRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn))
-> [LGRHS GhcRn (LHsExpr GhcRn)] -> [LGRHS GhcRn (LHsExpr GhcRn)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LGRHS GhcRn (LHsExpr 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 -> Located [LMatch p body]
Ghc.mg_alts = Located [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 :: Located [LMatch GhcRn (LHsExpr GhcRn)]
Ghc.mg_alts = (([LMatch GhcRn (LHsExpr GhcRn)] -> [LMatch GhcRn (LHsExpr GhcRn)])
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([LMatch GhcRn (LHsExpr GhcRn)] -> [LMatch GhcRn (LHsExpr GhcRn)])
 -> Located [LMatch GhcRn (LHsExpr GhcRn)]
 -> Located [LMatch GhcRn (LHsExpr GhcRn)])
-> ((Match GhcRn (LHsExpr GhcRn) -> Match GhcRn (LHsExpr GhcRn))
    -> [LMatch GhcRn (LHsExpr GhcRn)]
    -> [LMatch GhcRn (LHsExpr GhcRn)])
-> (Match GhcRn (LHsExpr GhcRn) -> Match GhcRn (LHsExpr GhcRn))
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LMatch GhcRn (LHsExpr GhcRn) -> LMatch GhcRn (LHsExpr GhcRn))
-> [LMatch GhcRn (LHsExpr GhcRn)] -> [LMatch GhcRn (LHsExpr GhcRn)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LMatch GhcRn (LHsExpr GhcRn) -> LMatch GhcRn (LHsExpr GhcRn))
 -> [LMatch GhcRn (LHsExpr GhcRn)]
 -> [LMatch GhcRn (LHsExpr GhcRn)])
-> ((Match GhcRn (LHsExpr GhcRn) -> Match GhcRn (LHsExpr GhcRn))
    -> LMatch GhcRn (LHsExpr GhcRn) -> LMatch GhcRn (LHsExpr GhcRn))
-> (Match GhcRn (LHsExpr GhcRn) -> Match GhcRn (LHsExpr GhcRn))
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> [LMatch GhcRn (LHsExpr GhcRn)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match GhcRn (LHsExpr GhcRn) -> Match GhcRn (LHsExpr GhcRn))
-> LMatch GhcRn (LHsExpr GhcRn) -> LMatch GhcRn (LHsExpr GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Match GhcRn (LHsExpr GhcRn) -> Match GhcRn (LHsExpr GhcRn)
updateMatch Located [LMatch GhcRn (LHsExpr GhcRn)]
alts }
      }
  where
    updateMatch :: Match GhcRn (LHsExpr GhcRn) -> Match GhcRn (LHsExpr GhcRn)
updateMatch mtch :: Match GhcRn (LHsExpr GhcRn)
mtch@Ghc.Match{m_grhss :: forall p body. Match p body -> GRHSs p body
Ghc.m_grhss = 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}}
      = Match GhcRn (LHsExpr GhcRn)
mtch{m_grhss :: GRHSs GhcRn (LHsExpr GhcRn)
Ghc.m_grhss =
               GRHSs GhcRn (LHsExpr GhcRn)
g{grhssGRHSs :: [LGRHS GhcRn (LHsExpr GhcRn)]
Ghc.grhssGRHSs = (GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn))
-> LGRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn)
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) (LGRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn))
-> [LGRHS GhcRn (LHsExpr GhcRn)] -> [LGRHS GhcRn (LHsExpr GhcRn)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LGRHS GhcRn (LHsExpr GhcRn)]
grhss }
            }
#if !(MIN_VERSION_ghc(9,0,0))
    updateMatch Match GhcRn (LHsExpr GhcRn)
x = Match GhcRn (LHsExpr GhcRn)
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 (LHsExpr GhcRn)]
Ghc.grhssGRHSs = (GRHS GhcRn (LHsExpr GhcRn) -> GRHS GhcRn (LHsExpr GhcRn))
-> LGRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn)
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) (LGRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn))
-> [LGRHS GhcRn (LHsExpr GhcRn)] -> [LGRHS GhcRn (LHsExpr GhcRn)]
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 String String
-> Propagation
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
mkNewIpExpr SrcSpan
srcSpan Either String String
newKey Propagation
newProp = do
  let mDefSite :: Maybe SrcCodeLoc
mDefSite = case SrcSpan -> SrcLoc
Ghc.srcSpanStart SrcSpan
srcSpan of
                   Ghc.RealSrcLoc' RealSrcLoc
loc ->
                     SrcCodeLoc -> Maybe SrcCodeLoc
forall a. a -> Maybe a
Just SrcCodeLoc :: String -> SrcLine -> SrcLine -> SrcCodeLoc
SrcCodeLoc
                       { srcModule :: String
srcModule = FastString -> String
Ghc.unpackFS (FastString -> String) -> FastString -> String
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
_ -> Maybe SrcCodeLoc
forall a. Maybe a
Nothing
  Right LHsExpr GhcPs
exprPs
    <- (Exp -> Either MsgDoc (LHsExpr GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) Exp
-> IOEnv (Env TcGblEnv TcLclEnv) (Either MsgDoc (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Origin -> SrcSpan -> Exp -> Either MsgDoc (LHsExpr GhcPs)
Ghc.convertToHsExpr Origin
Ghc.Generated SrcSpan
Ghc.noSrcSpan)
     (IOEnv (Env TcGblEnv TcLclEnv) Exp
 -> IOEnv (Env TcGblEnv TcLclEnv) (Either MsgDoc (LHsExpr GhcPs)))
-> (IO Exp -> IOEnv (Env TcGblEnv TcLclEnv) Exp)
-> IO Exp
-> IOEnv (Env TcGblEnv TcLclEnv) (Either MsgDoc (LHsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Exp -> IOEnv (Env TcGblEnv TcLclEnv) Exp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
     (IO Exp
 -> IOEnv (Env TcGblEnv TcLclEnv) (Either MsgDoc (LHsExpr GhcPs)))
-> IO Exp
-> IOEnv (Env TcGblEnv TcLclEnv) (Either MsgDoc (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Q Exp -> IO Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
TH.runQ [| noinline $! Just $! mkNewDebugContext mDefSite newKey newProp ?_debug_ip |]

  (LHsExpr GhcRn
exprRn, FreeVars
_) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
Ghc.rnLExpr LHsExpr GhcPs
exprPs

  LHsExpr GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr 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 String String
-> Propagation
-> Maybe DebugContext
-> DebugContext
mkNewDebugContext Maybe SrcCodeLoc
mDefSite Either String String
newKey Propagation
newProp Maybe DebugContext
mPrevCtx =
  case (Maybe DebugContext
mPrevCtx, Either String String
newKey) of
    -- If override key matches with previous tag, keep the id
    (Just DebugContext
prevCtx, Right String
userKey)
      | DebugTag -> Either String String
debugKey (DebugContext -> DebugTag
currentTag DebugContext
prevCtx) Either String String -> Either String String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Either String String
forall a b. b -> Either a b
Right String
userKey
      -> DebugContext
prevCtx
           { propagation :: Propagation
propagation = Maybe Propagation -> Propagation
getNextProp (Propagation -> Maybe Propagation
forall a. a -> Maybe a
Just (Propagation -> Maybe Propagation)
-> Propagation -> Maybe Propagation
forall a b. (a -> b) -> a -> b
$ DebugContext -> Propagation
propagation DebugContext
prevCtx) }
    (Maybe DebugContext, Either String String)
_ -> IO DebugContext -> DebugContext
forall a. IO a -> a
unsafePerformIO (IO DebugContext -> DebugContext)
-> IO DebugContext -> DebugContext
forall a b. (a -> b) -> a -> b
$ do
      Word
newId <- IO Word
forall a (m :: * -> *). (Random a, MonadIO m) => m a
Rand.randomIO :: IO Word
      let newTag :: DebugTag
newTag = DT :: Word -> Either String String -> DebugTag
DT
            { invocationId :: Word
invocationId = Word
newId
            , debugKey :: Either String String
debugKey = Either String String
newKey
            }
      DebugContext -> IO DebugContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        DC :: Maybe DebugTag
-> DebugTag -> Propagation -> Maybe SrcCodeLoc -> DebugContext
DC { previousTag :: Maybe DebugTag
previousTag = DebugContext -> DebugTag
currentTag (DebugContext -> DebugTag) -> Maybe DebugContext -> Maybe DebugTag
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 (DebugContext -> Propagation)
-> Maybe DebugContext -> Maybe 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. '$' is used to apply it
-- because it has same special impredicative type properties in ghc 9.2+.
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) =
  XCGRHS GhcRn (LHsExpr GhcRn)
-> [GuardLStmt GhcRn]
-> LHsExpr GhcRn
-> GRHS GhcRn (LHsExpr GhcRn)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x [GuardLStmt GhcRn]
guards (LHsExpr GhcRn -> GRHS GhcRn (LHsExpr GhcRn))
-> (HsExpr GhcRn -> LHsExpr GhcRn)
-> HsExpr GhcRn
-> GRHS GhcRn (LHsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcRn -> LHsExpr GhcRn
forall a. a -> Located a
Ghc.noLocA' (HsExpr GhcRn -> GRHS GhcRn (LHsExpr GhcRn))
-> HsExpr GhcRn -> GRHS GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$
    XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
Ghc.HsApp NoExtField
XApp GhcRn
Ghc.emptyEpAnn
      (HsExpr GhcRn -> LHsExpr GhcRn
forall a. a -> Located a
Ghc.noLocA' (HsExpr GhcRn -> LHsExpr GhcRn)
-> (Located Name -> HsExpr GhcRn) -> Located Name -> LHsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
Ghc.HsVar NoExtField
XVar GhcRn
Ghc.NoExtField (Located Name -> LHsExpr GhcRn) -> Located Name -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> Located Name
forall a. a -> Located a
Ghc.noLocA' Name
emitEntryName
      )
      LHsExpr GhcRn
body
#if !(MIN_VERSION_ghc(9,0,0))
emitEntryEvent Name
_ GRHS GhcRn (LHsExpr GhcRn)
x = GRHS GhcRn (LHsExpr GhcRn)
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)
  = XCGRHS GhcRn (LHsExpr GhcRn)
-> [GuardLStmt GhcRn]
-> LHsExpr GhcRn
-> GRHS GhcRn (LHsExpr GhcRn)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x (GuardLStmt GhcRn
ipUpdateGuard GuardLStmt GhcRn -> [GuardLStmt GhcRn] -> [GuardLStmt GhcRn]
forall a. a -> [a] -> [a]
: [GuardLStmt GhcRn]
guards) LHsExpr GhcRn
body
  where
    ipUpdateGuard :: GuardLStmt GhcRn
ipUpdateGuard =
      StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> GuardLStmt GhcRn
forall a. a -> Located a
Ghc.noLocA' (StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> GuardLStmt GhcRn)
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> GuardLStmt GhcRn
forall a b. (a -> b) -> a -> b
$
        XLetStmt GhcRn GhcRn (LHsExpr GhcRn)
-> LHsLocalBinds GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
Ghc.LetStmt NoExtField
XLetStmt GhcRn GhcRn (LHsExpr GhcRn)
Ghc.emptyEpAnn (LHsLocalBinds GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn))
-> LHsLocalBinds GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$
          HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn
forall a. a -> Located a
Ghc.noLoc' (HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn)
-> HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn
forall a b. (a -> b) -> a -> b
$
            XHsIPBinds GhcRn GhcRn
-> HsIPBinds GhcRn -> HsLocalBindsLR GhcRn GhcRn
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
Ghc.HsIPBinds NoExtField
XHsIPBinds GhcRn GhcRn
Ghc.emptyEpAnn (HsIPBinds GhcRn -> HsLocalBindsLR GhcRn GhcRn)
-> HsIPBinds GhcRn -> HsLocalBindsLR GhcRn GhcRn
forall a b. (a -> b) -> a -> b
$
              XIPBinds GhcRn -> [LIPBind GhcRn] -> HsIPBinds GhcRn
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
Ghc.IPBinds NoExtField
XIPBinds GhcRn
Ghc.NoExtField
                [ IPBind GhcRn -> LIPBind GhcRn
forall a. a -> Located a
Ghc.noLocA' (IPBind GhcRn -> LIPBind GhcRn) -> IPBind GhcRn -> LIPBind GhcRn
forall a b. (a -> b) -> a -> b
$ XCIPBind GhcRn
-> Either (Located HsIPName) (IdP GhcRn)
-> LHsExpr GhcRn
-> IPBind GhcRn
forall id.
XCIPBind id
-> Either (Located HsIPName) (IdP id) -> LHsExpr id -> IPBind id
Ghc.IPBind
                    NoExtField
XCIPBind GhcRn
Ghc.emptyEpAnn
                    (Located HsIPName -> Either (Located HsIPName) Name
forall a b. a -> Either a b
Left (Located HsIPName -> Either (Located HsIPName) Name)
-> (HsIPName -> Located HsIPName)
-> HsIPName
-> Either (Located HsIPName) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsIPName -> Located HsIPName
forall a. HasSrcSpan a => SrcSpanLess a -> a
Ghc.noLoc (HsIPName -> Either (Located HsIPName) Name)
-> HsIPName -> Either (Located HsIPName) Name
forall a b. (a -> b) -> a -> b
$ FastString -> HsIPName
Ghc.HsIPName FastString
"_debug_ip")
                    (HsExpr GhcRn -> LHsExpr GhcRn
forall a. a -> Located a
Ghc.noLocA' (HsExpr GhcRn -> LHsExpr GhcRn)
-> (Located Name -> HsExpr GhcRn) -> Located Name -> LHsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
Ghc.HsVar NoExtField
XVar GhcRn
Ghc.NoExtField
                      (Located Name -> LHsExpr GhcRn) -> Located Name -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> Located Name
forall a. a -> Located a
Ghc.noLocA' Name
whereBindName
                    )
                ]
#if !(MIN_VERSION_ghc(9,0,0))
updateDebugIPInGRHS Name
_ GRHS GhcRn (LHsExpr GhcRn)
x = GRHS GhcRn (LHsExpr GhcRn)
x
#endif

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