{-# LANGUAGE DeriveFunctor            #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TypeFamilies             #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

{-
(c) Galois, 2006
(c) University of Glasgow, 2007
-}

module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where

import GHC.Prelude as Prelude

import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Driver.Env

import qualified GHC.Runtime.Interpreter as GHCi
import GHCi.RemoteTypes
import GHC.ByteCode.Types
import GHC.Stack.CCS
import GHC.Hs
import GHC.Unit
import GHC.Cmm.CLabel

import GHC.Core.Type
import GHC.Core.TyCon

import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Data.Bag

import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Monad
import GHC.Utils.Logger

import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Name.Set hiding (FreeVars)
import GHC.Types.Name
import GHC.Types.HpcInfo
import GHC.Types.CostCentre
import GHC.Types.CostCentre.State
import GHC.Types.ForeignStubs
import GHC.Types.Tickish

import Control.Monad
import Data.List (isSuffixOf, intersperse)
import Data.Array
import Data.Time
import System.Directory

import Trace.Hpc.Mix
import Trace.Hpc.Util

import qualified Data.ByteString as BS
import Data.Set (Set)
import qualified Data.Set as Set

{-
************************************************************************
*                                                                      *
*              The main function: addTicksToBinds
*                                                                      *
************************************************************************
-}

addTicksToBinds
        :: HscEnv
        -> Module
        -> ModLocation          -- ... off the current module
        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
                                -- isExportedId doesn't work yet (the desugarer
                                -- hasn't set it), so we have to work from this set.
        -> [TyCon]              -- Type constructor in this module
        -> LHsBinds GhcTc
        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)

addTicksToBinds :: HscEnv
-> Module
-> ModLocation
-> NameSet
-> [TyCon]
-> LHsBinds GhcTc
-> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
addTicksToBinds HscEnv
hsc_env Module
mod ModLocation
mod_loc NameSet
exports [TyCon]
tyCons LHsBinds GhcTc
binds
  | let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        passes :: [TickishType]
passes = DynFlags -> [TickishType]
coveragePasses DynFlags
dflags
  , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TickishType]
passes)
  , Just FilePath
orig_file <- ModLocation -> Maybe FilePath
ml_hs_file ModLocation
mod_loc = do

     let  orig_file2 :: FilePath
orig_file2 = LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile LHsBinds GhcTc
binds FilePath
orig_file

          tickPass :: TickishType
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
    TickTransState)
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
    TickTransState)
tickPass TickishType
tickish (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds,TickTransState
st) =
            let env :: TickTransEnv
env = TTE
                      { fileName :: FastString
fileName     = FilePath -> FastString
mkFastString FilePath
orig_file2
                      , declPath :: [FilePath]
declPath     = []
                      , tte_dflags :: DynFlags
tte_dflags   = DynFlags
dflags
                      , exports :: NameSet
exports      = NameSet
exports
                      , inlines :: VarSet
inlines      = VarSet
emptyVarSet
                      , inScope :: VarSet
inScope      = VarSet
emptyVarSet
                      , blackList :: Set RealSrcSpan
blackList    = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
                                       forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\TyCon
tyCon -> case forall a. NamedThing a => a -> SrcSpan
getSrcSpan (TyCon -> Name
tyConName TyCon
tyCon) of
                                                             RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ -> forall a. a -> Maybe a
Just RealSrcSpan
l
                                                             UnhelpfulSpan UnhelpfulSpanReason
_ -> forall a. Maybe a
Nothing)
                                                [TyCon]
tyCons
                      , density :: TickDensity
density      = TickishType -> DynFlags -> TickDensity
mkDensity TickishType
tickish DynFlags
dflags
                      , this_mod :: Module
this_mod     = Module
mod
                      , tickishType :: TickishType
tickishType  = TickishType
tickish
                      }
                (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds',FreeVars
_,TickTransState
st') = forall a.
TM a
-> TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
unTM (LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds) TickTransEnv
env TickTransState
st
            in (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', TickTransState
st')

          initState :: TickTransState
initState = TT { tickBoxCount :: Int
tickBoxCount = Int
0
                         , mixEntries :: [MixEntry_]
mixEntries   = []
                         , ccIndices :: CostCentreState
ccIndices    = CostCentreState
newCostCentreState
                         }

          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1,TickTransState
st) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TickishType
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
    TickTransState)
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
    TickTransState)
tickPass (LHsBinds GhcTc
binds, TickTransState
initState) [TickishType]
passes

     let tickCount :: Int
tickCount = TickTransState -> Int
tickBoxCount TickTransState
st
         entries :: [MixEntry_]
entries = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ TickTransState -> [MixEntry_]
mixEntries TickTransState
st
     Int
hashNo <- DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries DynFlags
dflags Module
mod Int
tickCount [MixEntry_]
entries FilePath
orig_file2
     Maybe ModBreaks
modBreaks <- HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)
mkModBreaks HscEnv
hsc_env Module
mod Int
tickCount [MixEntry_]
entries

     let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
     Logger
-> DynFlags -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_ticked FilePath
"HPC" DumpFormat
FormatHaskell
       (forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1)

     forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, Int -> Int -> HpcInfo
HpcInfo Int
tickCount Int
hashNo, Maybe ModBreaks
modBreaks)

  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
binds, Bool -> HpcInfo
emptyHpcInfo Bool
False, forall a. Maybe a
Nothing)

guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile LHsBinds GhcTc
binds FilePath
orig_file =
     -- Try look for a file generated from a .hsc file to a
     -- .hs file, by peeking ahead.
     let top_pos :: [FastString]
top_pos = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (L SrcSpanAnnA
pos HsBindLR GhcTc GhcTc
_) [Maybe FastString]
rest ->
                               SrcSpan -> Maybe FastString
srcSpanFileName_maybe (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) forall a. a -> [a] -> [a]
: [Maybe FastString]
rest) [] LHsBinds GhcTc
binds
     in
     case [FastString]
top_pos of
        (FastString
file_name:[FastString]
_) | FilePath
".hsc" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FastString -> FilePath
unpackFS FastString
file_name
                      -> FastString -> FilePath
unpackFS FastString
file_name
        [FastString]
_ -> FilePath
orig_file


mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)
mkModBreaks HscEnv
hsc_env Module
mod Int
count [MixEntry_]
entries
  | Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
  , DynFlags -> Bool
breakpointsEnabled (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) = do
    ForeignRef BreakArray
breakArray <- Interp -> Int -> IO (ForeignRef BreakArray)
GHCi.newBreakArray Interp
interp (forall (t :: * -> *) a. Foldable t => t a -> Int
length [MixEntry_]
entries)
    Array Int (RemotePtr CostCentre)
ccs <- HscEnv
-> Module
-> Int
-> [MixEntry_]
-> IO (Array Int (RemotePtr CostCentre))
mkCCSArray HscEnv
hsc_env Module
mod Int
count [MixEntry_]
entries
    let
           locsTicks :: Array Int SrcSpan
locsTicks  = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countforall a. Num a => a -> a -> a
-Int
1) [ SrcSpan
span  | (SrcSpan
span,[FilePath]
_,[OccName]
_,BoxLabel
_)  <- [MixEntry_]
entries ]
           varsTicks :: Array Int [OccName]
varsTicks  = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countforall a. Num a => a -> a -> a
-Int
1) [ [OccName]
vars  | (SrcSpan
_,[FilePath]
_,[OccName]
vars,BoxLabel
_)  <- [MixEntry_]
entries ]
           declsTicks :: Array Int [FilePath]
declsTicks = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countforall a. Num a => a -> a -> a
-Int
1) [ [FilePath]
decls | (SrcSpan
_,[FilePath]
decls,[OccName]
_,BoxLabel
_) <- [MixEntry_]
entries ]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModBreaks
emptyModBreaks
                       { modBreaks_flags :: ForeignRef BreakArray
modBreaks_flags = ForeignRef BreakArray
breakArray
                       , modBreaks_locs :: Array Int SrcSpan
modBreaks_locs  = Array Int SrcSpan
locsTicks
                       , modBreaks_vars :: Array Int [OccName]
modBreaks_vars  = Array Int [OccName]
varsTicks
                       , modBreaks_decls :: Array Int [FilePath]
modBreaks_decls = Array Int [FilePath]
declsTicks
                       , modBreaks_ccs :: Array Int (RemotePtr CostCentre)
modBreaks_ccs   = Array Int (RemotePtr CostCentre)
ccs
                       }
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

mkCCSArray
  :: HscEnv -> Module -> Int -> [MixEntry_]
  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
mkCCSArray :: HscEnv
-> Module
-> Int
-> [MixEntry_]
-> IO (Array Int (RemotePtr CostCentre))
mkCCSArray HscEnv
hsc_env Module
modul Int
count [MixEntry_]
entries =
  case HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
    Just Interp
interp | Interp -> Bool
GHCi.interpreterProfiled Interp
interp -> do
      let module_str :: FilePath
module_str = ModuleName -> FilePath
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
modul)
      [RemotePtr CostCentre]
costcentres <- Interp
-> FilePath -> [(FilePath, FilePath)] -> IO [RemotePtr CostCentre]
GHCi.mkCostCentres Interp
interp FilePath
module_str (forall a b. (a -> b) -> [a] -> [b]
map MixEntry_ -> (FilePath, FilePath)
mk_one [MixEntry_]
entries)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countforall a. Num a => a -> a -> a
-Int
1) [RemotePtr CostCentre]
costcentres)

    Maybe Interp
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,-Int
1) [])
 where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    mk_one :: MixEntry_ -> (FilePath, FilePath)
mk_one (SrcSpan
srcspan, [FilePath]
decl_path, [OccName]
_, BoxLabel
_) = (FilePath
name, FilePath
src)
      where name :: FilePath
name = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse FilePath
"." [FilePath]
decl_path)
            src :: FilePath
src = DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr SrcSpan
srcspan)


writeMixEntries
  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries DynFlags
dflags Module
mod Int
count [MixEntry_]
entries FilePath
filename
  | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc DynFlags
dflags) = forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
  | Bool
otherwise   = do
        let
            hpc_dir :: FilePath
hpc_dir = DynFlags -> FilePath
hpcDir DynFlags
dflags
            mod_name :: FilePath
mod_name = ModuleName -> FilePath
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)

            hpc_mod_dir :: FilePath
hpc_mod_dir
              | forall unit. GenModule unit -> unit
moduleUnit Module
mod forall a. Eq a => a -> a -> Bool
== Unit
mainUnit  = FilePath
hpc_dir
              | Bool
otherwise = FilePath
hpc_dir forall a. [a] -> [a] -> [a]
++ FilePath
"/" forall a. [a] -> [a] -> [a]
++ forall u. IsUnitId u => u -> FilePath
unitString (forall unit. GenModule unit -> unit
moduleUnit Module
mod)

            tabStop :: Int
tabStop = Int
8 -- <tab> counts as a normal char in GHC's
                        -- location ranges.

        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
hpc_mod_dir
        UTCTime
modTime <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
filename
        let entries' :: [(HpcPos, BoxLabel)]
entries' = [ (HpcPos
hpcPos, BoxLabel
box)
                       | (SrcSpan
span,[FilePath]
_,[OccName]
_,BoxLabel
box) <- [MixEntry_]
entries, HpcPos
hpcPos <- [SrcSpan -> HpcPos
mkHpcPos SrcSpan
span] ]
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(HpcPos, BoxLabel)]
entries' forall a. [a] -> Int -> Bool
`lengthIsNot` Int
count) forall a b. (a -> b) -> a -> b
$
          forall a. FilePath -> a
panic FilePath
"the number of .mix entries are inconsistent"
        let hashNo :: Int
hashNo = FilePath -> UTCTime -> Int -> [(HpcPos, BoxLabel)] -> Int
mixHash FilePath
filename UTCTime
modTime Int
tabStop [(HpcPos, BoxLabel)]
entries'
        FilePath -> FilePath -> Mix -> IO ()
mixCreate FilePath
hpc_mod_dir FilePath
mod_name
                       forall a b. (a -> b) -> a -> b
$ FilePath -> UTCTime -> Hash -> Int -> [(HpcPos, BoxLabel)] -> Mix
Mix FilePath
filename UTCTime
modTime (forall a. HpcHash a => a -> Hash
toHash Int
hashNo) Int
tabStop [(HpcPos, BoxLabel)]
entries'
        forall (m :: * -> *) a. Monad m => a -> m a
return Int
hashNo


-- -----------------------------------------------------------------------------
-- TickDensity: where to insert ticks

data TickDensity
  = TickForCoverage       -- for Hpc
  | TickForBreakPoints    -- for GHCi
  | TickAllFunctions      -- for -prof-auto-all
  | TickTopFunctions      -- for -prof-auto-top
  | TickExportedFunctions -- for -prof-auto-exported
  | TickCallSites         -- for stack tracing
  deriving TickDensity -> TickDensity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TickDensity -> TickDensity -> Bool
$c/= :: TickDensity -> TickDensity -> Bool
== :: TickDensity -> TickDensity -> Bool
$c== :: TickDensity -> TickDensity -> Bool
Eq

mkDensity :: TickishType -> DynFlags -> TickDensity
mkDensity :: TickishType -> DynFlags -> TickDensity
mkDensity TickishType
tickish DynFlags
dflags = case TickishType
tickish of
  TickishType
HpcTicks             -> TickDensity
TickForCoverage
  TickishType
SourceNotes          -> TickDensity
TickForCoverage
  TickishType
Breakpoints          -> TickDensity
TickForBreakPoints
  TickishType
ProfNotes ->
    case DynFlags -> ProfAuto
profAuto DynFlags
dflags of
      ProfAuto
ProfAutoAll      -> TickDensity
TickAllFunctions
      ProfAuto
ProfAutoTop      -> TickDensity
TickTopFunctions
      ProfAuto
ProfAutoExports  -> TickDensity
TickExportedFunctions
      ProfAuto
ProfAutoCalls    -> TickDensity
TickCallSites
      ProfAuto
_other           -> forall a. FilePath -> a
panic FilePath
"mkDensity"

-- | Decide whether to add a tick to a binding or not.
shouldTickBind  :: TickDensity
                -> Bool         -- top level?
                -> Bool         -- exported?
                -> Bool         -- simple pat bind?
                -> Bool         -- INLINE pragma?
                -> Bool

shouldTickBind :: TickDensity -> Bool -> Bool -> Bool -> Bool -> Bool
shouldTickBind TickDensity
density Bool
top_lev Bool
exported Bool
_simple_pat Bool
inline
 = case TickDensity
density of
      TickDensity
TickForBreakPoints    -> Bool
False
        -- we never add breakpoints to simple pattern bindings
        -- (there's always a tick on the rhs anyway).
      TickDensity
TickAllFunctions      -> Bool -> Bool
not Bool
inline
      TickDensity
TickTopFunctions      -> Bool
top_lev Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inline
      TickDensity
TickExportedFunctions -> Bool
exported Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inline
      TickDensity
TickForCoverage       -> Bool
True
      TickDensity
TickCallSites         -> Bool
False

shouldTickPatBind :: TickDensity -> Bool -> Bool
shouldTickPatBind :: TickDensity -> Bool -> Bool
shouldTickPatBind TickDensity
density Bool
top_lev
  = case TickDensity
density of
      TickDensity
TickForBreakPoints    -> Bool
False
      TickDensity
TickAllFunctions      -> Bool
True
      TickDensity
TickTopFunctions      -> Bool
top_lev
      TickDensity
TickExportedFunctions -> Bool
False
      TickDensity
TickForCoverage       -> Bool
False
      TickDensity
TickCallSites         -> Bool
False

-- -----------------------------------------------------------------------------
-- Adding ticks to bindings

addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind

addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind (L SrcSpanAnnA
pos bind :: HsBindLR GhcTc GhcTc
bind@(AbsBinds { abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds   = LHsBinds GhcTc
binds,
                                       abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport GhcTc]
abs_exports })) =
  forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
add_exports forall a b. (a -> b) -> a -> b
$
    forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
add_inlines forall a b. (a -> b) -> a -> b
$ do
      Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds' <- LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds LHsBinds GhcTc
binds
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos forall a b. (a -> b) -> a -> b
$ HsBindLR GhcTc GhcTc
bind { abs_binds :: LHsBinds GhcTc
abs_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds' }
  where
   -- in AbsBinds, the Id on each binding is not the actual top-level
   -- Id that we are defining, they are related by the abs_exports
   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
   -- to add the local Ids to the set of exported Names so that we know to
   -- tick the right bindings.
   add_exports :: TickTransEnv -> TickTransEnv
add_exports TickTransEnv
env =
     TickTransEnv
env{ exports :: NameSet
exports = TickTransEnv -> NameSet
exports TickTransEnv
env NameSet -> [Name] -> NameSet
`extendNameSetList`
                      [ Var -> Name
idName IdP GhcTc
mid
                      | ABE{ abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
pid, abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
mid } <- [ABExport GhcTc]
abs_exports
                      , Var -> Name
idName IdP GhcTc
pid Name -> NameSet -> Bool
`elemNameSet` (TickTransEnv -> NameSet
exports TickTransEnv
env) ] }

   -- See Note [inline sccs]
   add_inlines :: TickTransEnv -> TickTransEnv
add_inlines TickTransEnv
env =
     TickTransEnv
env{ inlines :: VarSet
inlines = TickTransEnv -> VarSet
inlines TickTransEnv
env VarSet -> [Var] -> VarSet
`extendVarSetList`
                      [ IdP GhcTc
mid
                      | ABE{ abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
pid, abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
mid } <- [ABExport GhcTc]
abs_exports
                      , InlinePragma -> Bool
isInlinePragma (Var -> InlinePragma
idInlinePragma IdP GhcTc
pid) ] }

addTickLHsBind (L SrcSpanAnnA
pos (funBind :: HsBindLR GhcTc GhcTc
funBind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Var
id }))) = do
  let name :: FilePath
name = forall a. NamedThing a => a -> FilePath
getOccString Var
id
  [FilePath]
decl_path <- TM [FilePath]
getPathEntry
  TickDensity
density <- TM TickDensity
getDensity

  VarSet
inline_ids <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TickTransEnv -> VarSet
inlines TM TickTransEnv
getEnv
  -- See Note [inline sccs]
  let inline :: Bool
inline   = InlinePragma -> Bool
isInlinePragma (Var -> InlinePragma
idInlinePragma Var
id)
                 Bool -> Bool -> Bool
|| Var
id Var -> VarSet -> Bool
`elemVarSet` VarSet
inline_ids

  -- See Note [inline sccs]
  TickishType
tickish <- TickTransEnv -> TickishType
tickishType forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TM TickTransEnv
getEnv
  if Bool
inline Bool -> Bool -> Bool
&& TickishType
tickish forall a. Eq a => a -> a -> Bool
== TickishType
ProfNotes then forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos HsBindLR GhcTc GhcTc
funBind) else do

  (FreeVars
fvs, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg) <-
        forall a. TM a -> TM (FreeVars, a)
getFreeVars forall a b. (a -> b) -> a -> b
$
        forall a. FilePath -> TM a -> TM a
addPathEntry FilePath
name forall a b. (a -> b) -> a -> b
$
        Bool
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup Bool
False (forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches HsBindLR GhcTc GhcTc
funBind)

  Bool
blackListed <- SrcSpan -> TM Bool
isBlackListed (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos)
  NameSet
exported_names <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TickTransEnv -> NameSet
exports TM TickTransEnv
getEnv

  -- We don't want to generate code for blacklisted positions
  -- We don't want redundant ticks on simple pattern bindings
  -- We don't want to tick non-exported bindings in TickExportedFunctions
  let simple :: Bool
simple = HsBindLR GhcTc GhcTc -> Bool
isSimplePatBind HsBindLR GhcTc GhcTc
funBind
      toplev :: Bool
toplev = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
decl_path
      exported :: Bool
exported = Var -> Name
idName Var
id Name -> NameSet -> Bool
`elemNameSet` NameSet
exported_names

  Maybe CoreTickish
tick <- if Bool -> Bool
not Bool
blackListed Bool -> Bool -> Bool
&&
               TickDensity -> Bool -> Bool -> Bool -> Bool -> Bool
shouldTickBind TickDensity
density Bool
toplev Bool
exported Bool
simple Bool
inline
             then
                TickDensity
-> FilePath -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
bindTick TickDensity
density FilePath
name (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) FreeVars
fvs
             else
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  let mbCons :: Maybe a -> [a] -> [a]
mbCons = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
Prelude.id (:)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos forall a b. (a -> b) -> a -> b
$ HsBindLR GhcTc GhcTc
funBind { fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg
                           , fun_tick :: [CoreTickish]
fun_tick = Maybe CoreTickish
tick forall {a}. Maybe a -> [a] -> [a]
`mbCons` forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick HsBindLR GhcTc GhcTc
funBind }

   where
   -- a binding is a simple pattern binding if it is a funbind with
   -- zero patterns
   isSimplePatBind :: HsBind GhcTc -> Bool
   isSimplePatBind :: HsBindLR GhcTc GhcTc -> Bool
isSimplePatBind HsBindLR GhcTc GhcTc
funBind = forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Int
matchGroupArity (forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches HsBindLR GhcTc GhcTc
funBind) forall a. Eq a => a -> a -> Bool
== Int
0

-- TODO: Revisit this
addTickLHsBind (L SrcSpanAnnA
pos (pat :: HsBindLR GhcTc GhcTc
pat@(PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
lhs
                                    , pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
rhs }))) = do

  let simplePatId :: Maybe (IdP GhcTc)
simplePatId = forall (x :: Pass). LPat (GhcPass x) -> Maybe (IdP (GhcPass x))
isSimplePat LPat GhcTc
lhs

  -- TODO: better name for rhs's for non-simple patterns?
  let name :: FilePath
name = forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"(...)" forall a. NamedThing a => a -> FilePath
getOccString Maybe (IdP GhcTc)
simplePatId

  (FreeVars
fvs, GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs') <- forall a. TM a -> TM (FreeVars, a)
getFreeVars forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> TM a -> TM a
addPathEntry FilePath
name forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs Bool
False Bool
False GRHSs GhcTc (LHsExpr GhcTc)
rhs
  let pat' :: HsBindLR GhcTc GhcTc
pat' = HsBindLR GhcTc GhcTc
pat { pat_rhs :: GRHSs GhcTc (LHsExpr GhcTc)
pat_rhs = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs'}

  -- Should create ticks here?
  TickDensity
density <- TM TickDensity
getDensity
  [FilePath]
decl_path <- TM [FilePath]
getPathEntry
  let top_lev :: Bool
top_lev = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
decl_path
  if Bool -> Bool
not (TickDensity -> Bool -> Bool
shouldTickPatBind TickDensity
density Bool
top_lev)
    then forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos HsBindLR GhcTc GhcTc
pat')
    else do

    let mbCons :: Maybe a -> [a] -> [a]
mbCons = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:)

    let ([CoreTickish]
initial_rhs_ticks, [[CoreTickish]]
initial_patvar_tickss) = forall idL idR.
HsBindLR idL idR -> ([CoreTickish], [[CoreTickish]])
pat_ticks HsBindLR GhcTc GhcTc
pat'

    -- Allocate the ticks

    Maybe CoreTickish
rhs_tick <- TickDensity
-> FilePath -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
bindTick TickDensity
density FilePath
name (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) FreeVars
fvs
    let rhs_ticks :: [CoreTickish]
rhs_ticks = Maybe CoreTickish
rhs_tick forall {a}. Maybe a -> [a] -> [a]
`mbCons` [CoreTickish]
initial_rhs_ticks

    [[CoreTickish]]
patvar_tickss <- case Maybe (IdP GhcTc)
simplePatId of
      Just{} -> forall (m :: * -> *) a. Monad m => a -> m a
return [[CoreTickish]]
initial_patvar_tickss
      Maybe (IdP GhcTc)
Nothing -> do
        let patvars :: [FilePath]
patvars = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> FilePath
getOccString (forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
lhs)
        [Maybe CoreTickish]
patvar_ticks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FilePath
v -> TickDensity
-> FilePath -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
bindTick TickDensity
density FilePath
v (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) FreeVars
fvs) [FilePath]
patvars
        forall (m :: * -> *) a. Monad m => a -> m a
return
          (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. Maybe a -> [a] -> [a]
mbCons [Maybe CoreTickish]
patvar_ticks
                          ([[CoreTickish]]
initial_patvar_tickss forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat []))

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos forall a b. (a -> b) -> a -> b
$ HsBindLR GhcTc GhcTc
pat' { pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_ticks = ([CoreTickish]
rhs_ticks, [[CoreTickish]]
patvar_tickss) }

-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind :: LHsBind GhcTc
var_bind@(L SrcSpanAnnA
_ (VarBind {})) = forall (m :: * -> *) a. Monad m => a -> m a
return LHsBind GhcTc
var_bind
addTickLHsBind patsyn_bind :: LHsBind GhcTc
patsyn_bind@(L SrcSpanAnnA
_ (PatSynBind {})) = forall (m :: * -> *) a. Monad m => a -> m a
return LHsBind GhcTc
patsyn_bind

bindTick
  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
bindTick :: TickDensity
-> FilePath -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
bindTick TickDensity
density FilePath
name SrcSpan
pos FreeVars
fvs = do
  [FilePath]
decl_path <- TM [FilePath]
getPathEntry
  let
      toplev :: Bool
toplev        = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
decl_path
      count_entries :: Bool
count_entries = Bool
toplev Bool -> Bool -> Bool
|| TickDensity
density forall a. Eq a => a -> a -> Bool
== TickDensity
TickAllFunctions
      top_only :: Bool
top_only      = TickDensity
density forall a. Eq a => a -> a -> Bool
/= TickDensity
TickAllFunctions
      box_label :: BoxLabel
box_label     = if Bool
toplev then [FilePath] -> BoxLabel
TopLevelBox [FilePath
name]
                                else [FilePath] -> BoxLabel
LocalBox ([FilePath]
decl_path forall a. [a] -> [a] -> [a]
++ [FilePath
name])
  --
  BoxLabel
-> Bool -> Bool -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
allocATickBox BoxLabel
box_label Bool
count_entries Bool
top_only SrcSpan
pos FreeVars
fvs


-- Note [inline sccs]
--
-- The reason not to add ticks to INLINE functions is that this is
-- sometimes handy for avoiding adding a tick to a particular function
-- (see #6131)
--
-- So for now we do not add any ticks to INLINE functions at all.
--
-- We used to use isAnyInlinePragma to figure out whether to avoid adding
-- ticks for this purpose. However, #12962 indicates that this contradicts
-- the documentation on profiling (which only mentions INLINE pragmas).
-- So now we're more careful about what we avoid adding ticks to.

-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr e :: LHsExpr GhcTc
e@(L SrcSpanAnnA
pos HsExpr GhcTc
e0) = do
  TickDensity
d <- TM TickDensity
getDensity
  case TickDensity
d of
    TickDensity
TickForBreakPoints | HsExpr GhcTc -> Bool
isGoodBreakExpr HsExpr GhcTc
e0 -> TM (LHsExpr GhcTc)
tick_it
    TickDensity
TickForCoverage    -> TM (LHsExpr GhcTc)
tick_it
    TickDensity
TickCallSites      | HsExpr GhcTc -> Bool
isCallSite HsExpr GhcTc
e0      -> TM (LHsExpr GhcTc)
tick_it
    TickDensity
_other             -> TM (LHsExpr GhcTc)
dont_tick_it
 where
   tick_it :: TM (LHsExpr GhcTc)
tick_it      = BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
False) Bool
False Bool
False (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos)
                  forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e0
   dont_tick_it :: TM (LHsExpr GhcTc)
dont_tick_it = LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e

-- Add a tick to an expression which is the RHS of an equation or a binding.
-- We always consider these to be breakpoints, unless the expression is a 'let'
-- (because the body will definitely have a tick somewhere).  ToDo: perhaps
-- we should treat 'case' and 'if' the same way?
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS e :: LHsExpr GhcTc
e@(L SrcSpanAnnA
pos HsExpr GhcTc
e0) = do
  TickDensity
d <- TM TickDensity
getDensity
  case TickDensity
d of
     TickDensity
TickForBreakPoints | HsLet{} <- HsExpr GhcTc
e0 -> TM (LHsExpr GhcTc)
dont_tick_it
                        | Bool
otherwise     -> TM (LHsExpr GhcTc)
tick_it
     TickDensity
TickForCoverage -> TM (LHsExpr GhcTc)
tick_it
     TickDensity
TickCallSites   | HsExpr GhcTc -> Bool
isCallSite HsExpr GhcTc
e0 -> TM (LHsExpr GhcTc)
tick_it
     TickDensity
_other          -> TM (LHsExpr GhcTc)
dont_tick_it
 where
   tick_it :: TM (LHsExpr GhcTc)
tick_it      = BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
False) Bool
False Bool
False (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos)
                  forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e0
   dont_tick_it :: TM (LHsExpr GhcTc)
dont_tick_it = LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e

-- The inner expression of an evaluation context:
--    let binds in [], ( [] )
-- we never tick these if we're doing HPC, but otherwise
-- we treat it like an ordinary expression.
addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprEvalInner LHsExpr GhcTc
e = do
   TickDensity
d <- TM TickDensity
getDensity
   case TickDensity
d of
     TickDensity
TickForCoverage -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e
     TickDensity
_otherwise      -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e

-- | A let body is treated differently from addTickLHsExprEvalInner
-- above with TickForBreakPoints, because for breakpoints we always
-- want to tick the body, even if it is not a redex.  See test
-- break012.  This gives the user the opportunity to inspect the
-- values of the let-bound variables.
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprLetBody e :: LHsExpr GhcTc
e@(L SrcSpanAnnA
pos HsExpr GhcTc
e0) = do
  TickDensity
d <- TM TickDensity
getDensity
  case TickDensity
d of
     TickDensity
TickForBreakPoints | HsLet{} <- HsExpr GhcTc
e0 -> TM (LHsExpr GhcTc)
dont_tick_it
                        | Bool
otherwise     -> TM (LHsExpr GhcTc)
tick_it
     TickDensity
_other -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprEvalInner LHsExpr GhcTc
e
 where
   tick_it :: TM (LHsExpr GhcTc)
tick_it      = BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
False) Bool
False Bool
False (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos)
                  forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e0
   dont_tick_it :: TM (LHsExpr GhcTc)
dont_tick_it = LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e

-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever (L SrcSpanAnnA
pos HsExpr GhcTc
e0) = do
    HsExpr GhcTc
e1 <- HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e0
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos HsExpr GhcTc
e1

-- General heuristic: expressions which are calls (do not denote
-- values) are good break points.
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr HsExpr GhcTc
e = HsExpr GhcTc -> Bool
isCallSite HsExpr GhcTc
e

isCallSite :: HsExpr GhcTc -> Bool
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{}     = Bool
True
isCallSite HsAppType{} = Bool
True
isCallSite (XExpr (ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
e)))
                       = HsExpr GhcTc -> Bool
isCallSite HsExpr GhcTc
e
-- NB: OpApp, SectionL, SectionR are all expanded out
isCallSite HsExpr GhcTc
_           = Bool
False

addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
oneOfMany (L SrcSpanAnnA
pos HsExpr GhcTc
e0)
  = forall a. TickDensity -> TM a -> TM a -> TM a
ifDensity TickDensity
TickForCoverage
        (BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
oneOfMany) Bool
False Bool
False (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos)
          forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e0)
        (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos HsExpr GhcTc
e0))

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr Bool -> BoxLabel
boxLabel (L SrcSpanAnnA
pos HsExpr GhcTc
e0)
  = forall a. TickDensity -> TM a -> TM a -> TM a
ifDensity TickDensity
TickForCoverage
        ((Bool -> BoxLabel)
-> SrcSpan -> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
allocBinTickBox Bool -> BoxLabel
boxLabel (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e0)
        (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos HsExpr GhcTc
e0))


-- -----------------------------------------------------------------------------
-- Decorate the body of an HsExpr with ticks.
-- (Whether to put a tick around the whole expression was already decided,
-- in the addTickLHsExpr family of functions.)

addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr e :: HsExpr GhcTc
e@(HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
id))  = do Var -> TM ()
freeVar Var
id; forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsUnboundVar {})   = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsRecFld XRecFld GhcTc
_ (Ambiguous XAmbiguous GhcTc
id LocatedN RdrName
_))   = do Var -> TM ()
freeVar XAmbiguous GhcTc
id; forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsRecFld XRecFld GhcTc
_ (Unambiguous XUnambiguous GhcTc
id LocatedN RdrName
_)) = do Var -> TM ()
freeVar XUnambiguous GhcTc
id; forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e

addTickHsExpr e :: HsExpr GhcTc
e@(HsConLikeOut {}) = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
  -- We used to do a freeVar on a pat-syn builder, but actually
  -- such builders are never in the inScope env, which
  -- doesn't include top level bindings
addTickHsExpr e :: HsExpr GhcTc
e@(HsIPVar {})     = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsOverLit {})   = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsOverLabel{})  = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsLit {})       = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr (HsLam XLam GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
mg)       = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
x)
                                         (Bool
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup Bool
True MatchGroup GhcTc (LHsExpr GhcTc)
mg)
addTickHsExpr (HsLamCase XLamCase GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
mgs)  = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcTc
x)
                                         (Bool
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup Bool
True MatchGroup GhcTc (LHsExpr GhcTc)
mgs)
addTickHsExpr (HsApp XApp GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)    = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
x) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e1)
                                                    (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr      LHsExpr GhcTc
e2)
addTickHsExpr (HsAppType XAppTypeE GhcTc
x LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
ty) = forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType (forall (m :: * -> *) a. Monad m => a -> m a
return XAppTypeE GhcTc
x)
                                                    (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e)
                                                    (forall (m :: * -> *) a. Monad m => a -> m a
return LHsWcType (NoGhcTc GhcTc)
ty)
addTickHsExpr (OpApp XOpApp GhcTc
fix LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) =
        forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp
                (forall (m :: * -> *) a. Monad m => a -> m a
return XOpApp GhcTc
fix)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e2)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e3)
addTickHsExpr (NegApp XNegApp GhcTc
x LHsExpr GhcTc
e SyntaxExpr GhcTc
neg) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcTc
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
neg)
addTickHsExpr (HsPar XPar GhcTc
x LHsExpr GhcTc
e) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcTc
x) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprEvalInner LHsExpr GhcTc
e)
addTickHsExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcTc
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e2)
addTickHsExpr (SectionR XSectionR GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcTc
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e1)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e2)
addTickHsExpr (ExplicitTuple XExplicitTuple GhcTc
x [HsTupArg GhcTc]
es Boxity
boxity) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcTc
x)
                (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg [HsTupArg GhcTc]
es)
                (forall (m :: * -> *) a. Monad m => a -> m a
return Boxity
boxity)
addTickHsExpr (ExplicitSum XExplicitSum GhcTc
ty Int
tag Int
arity LHsExpr GhcTc
e) = do
        GenLocated SrcSpanAnnA (HsExpr GhcTc)
e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcTc
ty Int
tag Int
arity GenLocated SrcSpanAnnA (HsExpr GhcTc)
e')
addTickHsExpr (HsCase XCase GhcTc
x LHsExpr GhcTc
e MatchGroup GhcTc (LHsExpr GhcTc)
mgs) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcTc
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e) -- not an EvalInner; e might not necessarily
                                   -- be evaluated.
                (Bool
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup Bool
False MatchGroup GhcTc (LHsExpr GhcTc)
mgs)
addTickHsExpr (HsIf XIf GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcTc
x)
                ((Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr (CondBox -> Bool -> BoxLabel
BinBox CondBox
CondBinBox) LHsExpr GhcTc
e1)
                (Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
True LHsExpr GhcTc
e2)
                (Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
True LHsExpr GhcTc
e3)
addTickHsExpr (HsMultiIf XMultiIf GhcTc
ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
  = do { let isOneOfMany :: Bool
isOneOfMany = case [LGRHS GhcTc (LHsExpr GhcTc)]
alts of [LGRHS GhcTc (LHsExpr GhcTc)
_] -> Bool
False; [LGRHS GhcTc (LHsExpr GhcTc)]
_ -> Bool
True
       ; [GenLocated
   SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS Bool
isOneOfMany Bool
False) [LGRHS GhcTc (LHsExpr GhcTc)]
alts
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf XMultiIf GhcTc
ty [GenLocated
   SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts' }
addTickHsExpr (HsLet XLet GhcTc
x HsLocalBinds GhcTc
binds LHsExpr GhcTc
e) =
        forall a. [Var] -> TM a -> TM a
bindLocals (forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcTc
binds) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcTc
x)
                  (HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
binds) -- to think about: !patterns.
                  (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprLetBody LHsExpr GhcTc
e)
addTickHsExpr (HsDo XDo GhcTc
srcloc HsStmtContext (HsDoRn GhcTc)
cxt (L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts))
  = do { ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', ()
_) <- forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' Maybe (Bool -> BoxLabel)
forQual [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts (forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
srcloc HsStmtContext (HsDoRn GhcTc)
cxt (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts')) }
  where
        forQual :: Maybe (Bool -> BoxLabel)
forQual = case HsStmtContext (HsDoRn GhcTc)
cxt of
                    HsStmtContext (HsDoRn GhcTc)
ListComp -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CondBox -> Bool -> BoxLabel
BinBox CondBox
QualBinBox
                    HsStmtContext (HsDoRn GhcTc)
_        -> forall a. Maybe a
Nothing
addTickHsExpr (ExplicitList XExplicitList GhcTc
ty [LHsExpr GhcTc]
es)
  = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList (forall (m :: * -> *) a. Monad m => a -> m a
return XExplicitList GhcTc
ty) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr) [LHsExpr GhcTc]
es)

addTickHsExpr (HsStatic XStatic GhcTc
fvs LHsExpr GhcTc
e) = forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcTc
fvs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e

addTickHsExpr expr :: HsExpr GhcTc
expr@(RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
rec_binds })
  = do { HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_binds' <- HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
addTickHsRecordBinds HsRecordBinds GhcTc
rec_binds
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr { rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_binds' }) }

addTickHsExpr expr :: HsExpr GhcTc
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
e, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Left [LHsRecUpdField GhcTc]
flds })
  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
       ; [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
flds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall id.
LHsRecField' GhcTc id (LHsExpr GhcTc)
-> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))
addTickHsRecField [LHsRecUpdField GhcTc]
flds
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr { rupd_expr :: LHsExpr GhcTc
rupd_expr = GenLocated SrcSpanAnnA (HsExpr GhcTc)
e', rupd_flds :: Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
rupd_flds = forall a b. a -> Either a b
Left [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
flds' }) }
addTickHsExpr expr :: HsExpr GhcTc
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
e, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Right [LHsRecUpdProj GhcTc]
flds })
  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
       ; [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldLabelStrings GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
flds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall id.
LHsRecField' GhcTc id (LHsExpr GhcTc)
-> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))
addTickHsRecField [LHsRecUpdProj GhcTc]
flds
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr { rupd_expr :: LHsExpr GhcTc
rupd_expr = GenLocated SrcSpanAnnA (HsExpr GhcTc)
e', rupd_flds :: Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
rupd_flds = forall a b. b -> Either a b
Right [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldLabelStrings GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
flds' }) }

addTickHsExpr (ExprWithTySig XExprWithTySig GhcTc
x LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
ty) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig
                (forall (m :: * -> *) a. Monad m => a -> m a
return XExprWithTySig GhcTc
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e) -- No need to tick the inner expression
                                        -- for expressions with signatures
                (forall (m :: * -> *) a. Monad m => a -> m a
return LHsSigWcType (NoGhcTc GhcTc)
ty)
addTickHsExpr (ArithSeq XArithSeq GhcTc
ty Maybe (SyntaxExpr GhcTc)
wit ArithSeqInfo GhcTc
arith_seq) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq
                (forall (m :: * -> *) a. Monad m => a -> m a
return XArithSeq GhcTc
ty)
                (Maybe SyntaxExprTc -> TM (Maybe SyntaxExprTc)
addTickWit Maybe (SyntaxExpr GhcTc)
wit)
                (ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo ArithSeqInfo GhcTc
arith_seq)
             where addTickWit :: Maybe SyntaxExprTc -> TM (Maybe SyntaxExprTc)
addTickWit Maybe SyntaxExprTc
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                   addTickWit (Just SyntaxExprTc
fl) = do SyntaxExprTc
fl' <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExprTc
fl
                                             forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just SyntaxExprTc
fl')

-- We might encounter existing ticks (multiple Coverage passes)
addTickHsExpr (HsTick XTick GhcTc
x CoreTickish
t LHsExpr GhcTc
e) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XTick p -> CoreTickish -> LHsExpr p -> HsExpr p
HsTick XTick GhcTc
x CoreTickish
t) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e)
addTickHsExpr (HsBinTick XBinTick GhcTc
x Int
t0 Int
t1 LHsExpr GhcTc
e) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XBinTick p -> Int -> Int -> LHsExpr p -> HsExpr p
HsBinTick XBinTick GhcTc
x Int
t0 Int
t1) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e)

addTickHsExpr (HsPragE XPragE GhcTc
x HsPragE GhcTc
p LHsExpr GhcTc
e) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcTc
x HsPragE GhcTc
p) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
addTickHsExpr e :: HsExpr GhcTc
e@(HsBracket     {})   = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsTcBracketOut  {}) = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsRnBracketOut  {}) = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsSpliceE  {})      = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsGetField {})      = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsProjection {})    = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr (HsProc XProc GhcTc
x LPat GhcTc
pat LHsCmdTop GhcTc
cmdtop) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcTc
x)
                (LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat)
                (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL (HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop) LHsCmdTop GhcTc
cmdtop)
addTickHsExpr (XExpr (WrapExpr (HsWrap HsWrapper
w HsExpr GhcTc
e))) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XXExpr p -> HsExpr p
XExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsWrap HsExpr -> XXExprGhcTc
WrapExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (hs_syn :: * -> *).
HsWrapper -> hs_syn GhcTc -> HsWrap hs_syn
HsWrap HsWrapper
w) forall a b. (a -> b) -> a -> b
$
              (HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e)        -- Explicitly no tick on inside
addTickHsExpr (XExpr (ExpansionExpr (HsExpanded HsExpr GhcRn
a HsExpr GhcTc
b))) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall p. XXExpr p -> HsExpr p
XExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc
ExpansionExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr GhcRn
a) forall a b. (a -> b) -> a -> b
$
              (HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
b)

addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg (Present XPresent GhcTc
x LHsExpr GhcTc
e)  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
                                  ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcTc
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
e') }
addTickTupArg (Missing XMissing GhcTc
ty) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XMissing id -> HsTupArg id
Missing XMissing GhcTc
ty)


addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup :: Bool
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup Bool
is_lam mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg@(MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches }) = do
  let isOneOfMany :: Bool
isOneOfMany = forall body. [LMatch GhcTc body] -> Bool
matchesOneOfMany [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches
  [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL (Bool
-> Bool
-> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch Bool
isOneOfMany Bool
is_lam)) [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MatchGroup GhcTc (LHsExpr GhcTc)
mg { mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches' }

addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
             -> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch :: Bool
-> Bool
-> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch Bool
isOneOfMany Bool
isLambda match :: Match GhcTc (LHsExpr GhcTc)
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcTc]
pats
                                               , m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (LHsExpr GhcTc)
gRHSs }) =
  forall a. [Var] -> TM a -> TM a
bindLocals (forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders forall p. CollectFlag p
CollNoDictBinders [LPat GhcTc]
pats) forall a b. (a -> b) -> a -> b
$ do
    GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
gRHSs' <- Bool
-> Bool
-> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs Bool
isOneOfMany Bool
isLambda GRHSs GhcTc (LHsExpr GhcTc)
gRHSs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Match GhcTc (LHsExpr GhcTc)
match { m_grhss :: GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
m_grhss = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
gRHSs' }

addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs :: Bool
-> Bool
-> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs Bool
isOneOfMany Bool
isLambda (GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
x [LGRHS GhcTc (LHsExpr GhcTc)]
guarded HsLocalBinds GhcTc
local_binds) =
  forall a. [Var] -> TM a -> TM a
bindLocals [IdP GhcTc]
binders forall a b. (a -> b) -> a -> b
$ do
    HsLocalBinds GhcTc
local_binds' <- HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
local_binds
    [GenLocated
   SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
guarded' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL (Bool
-> Bool
-> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS Bool
isOneOfMany Bool
isLambda)) [LGRHS GhcTc (LHsExpr GhcTc)]
guarded
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
x [GenLocated
   SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
guarded' HsLocalBinds GhcTc
local_binds'
  where
    binders :: [IdP GhcTc]
binders = forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcTc
local_binds

addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
            -> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS :: Bool
-> Bool
-> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS Bool
isOneOfMany Bool
isLambda (GRHS XCGRHS GhcTc (LHsExpr GhcTc)
x [ExprLStmt GhcTc]
stmts LHsExpr GhcTc
expr) = do
  ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts',GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CondBox -> Bool -> BoxLabel
BinBox forall a b. (a -> b) -> a -> b
$ CondBox
GuardBinBox) [ExprLStmt GhcTc]
stmts
                        (Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody Bool
isOneOfMany Bool
isLambda LHsExpr GhcTc
expr)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LHsExpr GhcTc)
x [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr'

addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody Bool
isOneOfMany Bool
isLambda expr :: LHsExpr GhcTc
expr@(L SrcSpanAnnA
pos HsExpr GhcTc
e0) = do
  TickDensity
d <- TM TickDensity
getDensity
  case TickDensity
d of
    TickDensity
TickForCoverage  -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
isOneOfMany LHsExpr GhcTc
expr
    TickDensity
TickAllFunctions | Bool
isLambda ->
       forall a. FilePath -> TM a -> TM a
addPathEntry FilePath
"\\" forall a b. (a -> b) -> a -> b
$
         BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
False) Bool
True{-count-} Bool
False{-not top-} (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) forall a b. (a -> b) -> a -> b
$
           HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e0
    TickDensity
_otherwise ->
       LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS LHsExpr GhcTc
expr

addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
              -> TM [ExprLStmt GhcTc]
addTickLStmts :: Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts = do
  ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts, ()
_) <- forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts (forall (m :: * -> *) a. Monad m => a -> m a
return ())
  forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts

addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
               -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' :: forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
lstmts TM a
res
  = forall a. [Var] -> TM a -> TM a
bindLocals (forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders forall p. CollectFlag p
CollNoDictBinders [ExprLStmt GhcTc]
lstmts) forall a b. (a -> b) -> a -> b
$
    do { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
lstmts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL (Maybe (Bool -> BoxLabel)
-> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
addTickStmt Maybe (Bool -> BoxLabel)
isGuard)) [ExprLStmt GhcTc]
lstmts
       ; a
a <- TM a
res
       ; forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
lstmts', a
a) }

addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
            -> TM (Stmt GhcTc (LHsExpr GhcTc))
addTickStmt :: Maybe (Bool -> BoxLabel)
-> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
addTickStmt Maybe (Bool -> BoxLabel)
_isGuard (LastStmt XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
x LHsExpr GhcTc
e Maybe Bool
noret SyntaxExpr GhcTc
ret) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
noret)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
ret)
addTickStmt Maybe (Bool -> BoxLabel)
_isGuard (BindStmt XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
xbs LPat GhcTc
pat LHsExpr GhcTc
e) =
        forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (\SyntaxExprTc
b Maybe SyntaxExprTc
f -> forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt forall a b. (a -> b) -> a -> b
$ XBindStmtTc
                    { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExprTc
b
                    , xbstc_boundResultType :: Type
xbstc_boundResultType = XBindStmtTc -> Type
xbstc_boundResultType XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
xbs
                    , xbstc_boundResultMult :: Type
xbstc_boundResultMult = XBindStmtTc -> Type
xbstc_boundResultMult XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
xbs
                    , xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp = Maybe SyntaxExprTc
f
                    })
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
xbs))
                (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan) (XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
xbs))
                (LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS LHsExpr GhcTc
e)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
x LHsExpr GhcTc
e SyntaxExpr GhcTc
bind' SyntaxExpr GhcTc
guard') =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
x)
                (Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick Maybe (Bool -> BoxLabel)
isGuard LHsExpr GhcTc
e)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bind')
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
guard')
addTickStmt Maybe (Bool -> BoxLabel)
_isGuard (LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
x HsLocalBinds GhcTc
binds) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
x)
                (HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
binds)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (ParStmt XParStmt GhcTc GhcTc (LHsExpr GhcTc)
x [ParStmtBlock GhcTc GhcTc]
pairs HsExpr GhcTc
mzipExpr SyntaxExpr GhcTc
bindExpr) =
    forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcTc GhcTc (LHsExpr GhcTc)
x)
        (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe (Bool -> BoxLabel)
-> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders Maybe (Bool -> BoxLabel)
isGuard) [ParStmtBlock GhcTc GhcTc]
pairs)
        (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
hpcSrcSpan) HsExpr GhcTc
mzipExpr))
        (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bindExpr)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join) = do
    [(SyntaxExprTc, ApplicativeArg GhcTc)]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe (Bool -> BoxLabel)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg Maybe (Bool -> BoxLabel)
isGuard) [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
body_ty [(SyntaxExprTc, ApplicativeArg GhcTc)]
args' Maybe (SyntaxExpr GhcTc)
mb_join)

addTickStmt Maybe (Bool -> BoxLabel)
isGuard stmt :: Stmt GhcTc (LHsExpr GhcTc)
stmt@(TransStmt { trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [ExprLStmt GhcTc]
stmts
                                    , trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcTc)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcTc
using
                                    , trS_ret :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_ret = SyntaxExpr GhcTc
returnExpr, trS_bind :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_bind = SyntaxExpr GhcTc
bindExpr
                                    , trS_fmap :: forall idL idR body. StmtLR idL idR body -> HsExpr idR
trS_fmap = HsExpr GhcTc
liftMExpr }) = do
    [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
t_s <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts
    Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
t_y <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
fmapMaybeM  LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS Maybe (LHsExpr GhcTc)
by
    GenLocated SrcSpanAnnA (HsExpr GhcTc)
t_u <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS LHsExpr GhcTc
using
    SyntaxExprTc
t_f <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
returnExpr
    SyntaxExprTc
t_b <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bindExpr
    HsExpr GhcTc
t_m <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
hpcSrcSpan) HsExpr GhcTc
liftMExpr))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Stmt GhcTc (LHsExpr GhcTc)
stmt { trS_stmts :: [ExprLStmt GhcTc]
trS_stmts = [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
t_s, trS_by :: Maybe (LHsExpr GhcTc)
trS_by = Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
t_y, trS_using :: LHsExpr GhcTc
trS_using = GenLocated SrcSpanAnnA (HsExpr GhcTc)
t_u
                  , trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExprTc
t_f, trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExprTc
t_b, trS_fmap :: HsExpr GhcTc
trS_fmap = HsExpr GhcTc
t_m }

addTickStmt Maybe (Bool -> BoxLabel)
isGuard stmt :: Stmt GhcTc (LHsExpr GhcTc)
stmt@(RecStmt {})
  = do { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard (forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; SyntaxExprTc
ret'   <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; SyntaxExprTc
mfix'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; SyntaxExprTc
bind'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt GhcTc (LHsExpr GhcTc)
stmt { recS_stmts :: XRec
  GhcTc [LStmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
recS_stmts = forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExprTc
ret'
                      , recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExprTc
mfix', recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExprTc
bind' }) }

addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick Maybe (Bool -> BoxLabel)
isGuard LHsExpr GhcTc
e | Just Bool -> BoxLabel
fn <- Maybe (Bool -> BoxLabel)
isGuard = (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr Bool -> BoxLabel
fn LHsExpr GhcTc
e
                  | Bool
otherwise          = LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS LHsExpr GhcTc
e

addTickApplicativeArg
  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg :: Maybe (Bool -> BoxLabel)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg Maybe (Bool -> BoxLabel)
isGuard (SyntaxExpr GhcTc
op, ApplicativeArg GhcTc
arg) =
  forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
op) (ApplicativeArg GhcTc -> TM (ApplicativeArg GhcTc)
addTickArg ApplicativeArg GhcTc
arg)
 where
  addTickArg :: ApplicativeArg GhcTc -> TM (ApplicativeArg GhcTc)
addTickArg (ApplicativeArgOne XApplicativeArgOne GhcTc
m_fail LPat GhcTc
pat LHsExpr GhcTc
expr Bool
isBody) =
    forall idL.
XApplicativeArgOne idL
-> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL
ApplicativeArgOne
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan) XApplicativeArgOne GhcTc
m_fail
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
expr
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isBody
  addTickArg (ApplicativeArgMany XApplicativeArgMany GhcTc
x [ExprLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
ctxt) =
    (forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsStmtContext (ApplicativeArgStmCtxPass idL)
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcTc
x)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
hpcSrcSpan) HsExpr GhcTc
ret))
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
ctxt

addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                      -> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel)
-> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders Maybe (Bool -> BoxLabel)
isGuard (ParStmtBlock XParStmtBlock GhcTc GhcTc
x [ExprLStmt GhcTc]
stmts [IdP GhcTc]
ids SyntaxExpr GhcTc
returnExpr) =
    forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcTc GhcTc
x)
        (Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts)
        (forall (m :: * -> *) a. Monad m => a -> m a
return [IdP GhcTc]
ids)
        (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
returnExpr)

addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds XHsValBinds GhcTc GhcTc
x HsValBindsLR GhcTc GhcTc
binds) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcTc GhcTc
x)
                (forall (a :: Pass) (b :: Pass).
HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds HsValBindsLR GhcTc GhcTc
binds)
addTickHsLocalBinds (HsIPBinds XHsIPBinds GhcTc GhcTc
x HsIPBinds GhcTc
binds)  =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds GhcTc GhcTc
x)
                (HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
addTickHsIPBinds HsIPBinds GhcTc
binds)
addTickHsLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
x)  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
x)

addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
                  -> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds :: forall (a :: Pass) (b :: Pass).
HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
sigs)) = do
        NHsValBindsLR GhcTc
b <- forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds
                (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (RecFlag
rec,Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds') ->
                                forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
                                        (forall (m :: * -> *) a. Monad m => a -> m a
return RecFlag
rec)
                                        (LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds'))
                        [(RecFlag, LHsBinds GhcTc)]
binds)
                (forall (m :: * -> *) a. Monad m => a -> m a
return [LSig GhcRn]
sigs)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR NHsValBindsLR GhcTc
b
addTickHsValBinds HsValBindsLR GhcTc (GhcPass a)
_ = forall a. FilePath -> a
panic FilePath
"addTickHsValBinds"

addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
addTickHsIPBinds (IPBinds XIPBinds GhcTc
dictbinds [LIPBind GhcTc]
ipbinds) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds
                (forall (m :: * -> *) a. Monad m => a -> m a
return XIPBinds GhcTc
dictbinds)
                (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL (IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind)) [LIPBind GhcTc]
ipbinds)

addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind (IPBind XCIPBind GhcTc
x Either (XRec GhcTc HsIPName) (IdP GhcTc)
nm LHsExpr GhcTc
e) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall id.
XCIPBind id
-> Either (XRec id HsIPName) (IdP id) -> LHsExpr id -> IPBind id
IPBind XCIPBind GhcTc
x)
                (forall (m :: * -> *) a. Monad m => a -> m a
return Either (XRec GhcTc HsIPName) (IdP GhcTc)
nm)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)

-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
pos syn :: SyntaxExpr GhcTc
syn@(SyntaxExprTc { syn_expr :: SyntaxExprTc -> HsExpr GhcTc
syn_expr = HsExpr GhcTc
x }) = do
        HsExpr GhcTc
x' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
pos) HsExpr GhcTc
x))
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcTc
syn { syn_expr :: HsExpr GhcTc
syn_expr = HsExpr GhcTc
x' }
addTickSyntaxExpr SrcSpan
_ SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc = forall (m :: * -> *) a. Monad m => a -> m a
return SyntaxExprTc
NoSyntaxExprTc

-- we do not walk into patterns.
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat = forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcTc
pat

addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop (HsCmdTop XCmdTop GhcTc
x LHsCmd GhcTc
cmd) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop
                (forall (m :: * -> *) a. Monad m => a -> m a
return XCmdTop GhcTc
x)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
cmd)

addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (L SrcSpanAnnA
pos HsCmd GhcTc
c0) = do
        HsCmd GhcTc
c1 <- HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd HsCmd GhcTc
c0
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos HsCmd GhcTc
c1

addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd (HsCmdLam XCmdLam GhcTc
x MatchGroup GhcTc (LHsCmd GhcTc)
matchgroup) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam XCmdLam GhcTc
x) (MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
addTickCmdMatchGroup MatchGroup GhcTc (LHsCmd GhcTc)
matchgroup)
addTickHsCmd (HsCmdApp XCmdApp GhcTc
x LHsCmd GhcTc
c LHsExpr GhcTc
e) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcTc
x) (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsCmd c2)
                (return fix)
                (addTickLHsCmd c3)
-}
addTickHsCmd (HsCmdPar XCmdPar GhcTc
x LHsCmd GhcTc
e) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar XCmdPar GhcTc
x) (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
e)
addTickHsCmd (HsCmdCase XCmdCase GhcTc
x LHsExpr GhcTc
e MatchGroup GhcTc (LHsCmd GhcTc)
mgs) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase XCmdCase GhcTc
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
                (MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
addTickCmdMatchGroup MatchGroup GhcTc (LHsCmd GhcTc)
mgs)
addTickHsCmd (HsCmdLamCase XCmdLamCase GhcTc
x MatchGroup GhcTc (LHsCmd GhcTc)
mgs) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall id. XCmdLamCase id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLamCase XCmdLamCase GhcTc
x) (MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
addTickCmdMatchGroup MatchGroup GhcTc (LHsCmd GhcTc)
mgs)
addTickHsCmd (HsCmdIf XCmdIf GhcTc
x SyntaxExpr GhcTc
cnd LHsExpr GhcTc
e1 LHsCmd GhcTc
c2 LHsCmd GhcTc
c3) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall id.
XCmdIf id
-> SyntaxExpr id
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcTc
x SyntaxExpr GhcTc
cnd)
                ((Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr (CondBox -> Bool -> BoxLabel
BinBox CondBox
CondBinBox) LHsExpr GhcTc
e1)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c2)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c3)
addTickHsCmd (HsCmdLet XCmdLet GhcTc
x HsLocalBinds GhcTc
binds LHsCmd GhcTc
c) =
        forall a. [Var] -> TM a -> TM a
bindLocals (forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcTc
binds) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall id. XCmdLet id -> HsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet XCmdLet GhcTc
x)
                   (HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
binds) -- to think about: !patterns.
                   (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
addTickHsCmd (HsCmdDo XCmdDo GhcTc
srcloc (L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts))
  = do { ([GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts', ()
_) <- forall a. [CmdLStmt GhcTc] -> TM a -> TM ([CmdLStmt GhcTc], a)
addTickLCmdStmts' [GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts (forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdDo id -> XRec id [CmdLStmt id] -> HsCmd id
HsCmdDo XCmdDo GhcTc
srcloc (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts')) }

addTickHsCmd (HsCmdArrApp  XCmdArrApp GhcTc
arr_ty LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
ty1 Bool
lr) =
        forall (m :: * -> *) a1 a2 a3 a4 a5 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> a5 -> r)
-> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
liftM5 forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp
               (forall (m :: * -> *) a. Monad m => a -> m a
return XCmdArrApp GhcTc
arr_ty)
               (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
               (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e2)
               (forall (m :: * -> *) a. Monad m => a -> m a
return HsArrAppType
ty1)
               (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
lr)
addTickHsCmd (HsCmdArrForm XCmdArrForm GhcTc
x LHsExpr GhcTc
e LexicalFixity
f Maybe Fixity
fix [LHsCmdTop GhcTc]
cmdtop) =
        forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcTc
x)
               (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
               (forall (m :: * -> *) a. Monad m => a -> m a
return LexicalFixity
f)
               (forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Fixity
fix)
               (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL (HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop)) [LHsCmdTop GhcTc]
cmdtop)

addTickHsCmd (XCmd (HsWrap HsWrapper
w HsCmd GhcTc
cmd)) =
  forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall id. XXCmd id -> HsCmd id
XCmd forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (hs_syn :: * -> *).
HsWrapper -> hs_syn GhcTc -> HsWrap hs_syn
HsWrap HsWrapper
w) (HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd HsCmd GhcTc
cmd)

-- Others should never happen in a command context.
--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)

addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
addTickCmdMatchGroup mg :: MatchGroup GhcTc (LHsCmd GhcTc)
mg@(MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
matches) }) = do
  [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
matches' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch) [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
matches
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MatchGroup GhcTc (LHsCmd GhcTc)
mg { mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
mg_alts = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
matches' }

addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch match :: Match GhcTc (LHsCmd GhcTc)
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcTc]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (LHsCmd GhcTc)
gRHSs }) =
  forall a. [Var] -> TM a -> TM a
bindLocals (forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders forall p. CollectFlag p
CollNoDictBinders [LPat GhcTc]
pats) forall a b. (a -> b) -> a -> b
$ do
    GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
gRHSs' <- GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs GRHSs GhcTc (LHsCmd GhcTc)
gRHSs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Match GhcTc (LHsCmd GhcTc)
match { m_grhss :: GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
m_grhss = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
gRHSs' }

addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs (GRHSs XCGRHSs GhcTc (LHsCmd GhcTc)
x [LGRHS GhcTc (LHsCmd GhcTc)]
guarded HsLocalBinds GhcTc
local_binds) =
  forall a. [Var] -> TM a -> TM a
bindLocals [IdP GhcTc]
binders forall a b. (a -> b) -> a -> b
$ do
    HsLocalBinds GhcTc
local_binds' <- HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
local_binds
    [GenLocated
   SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
guarded' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
addTickCmdGRHS) [LGRHS GhcTc (LHsCmd GhcTc)]
guarded
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LHsCmd GhcTc)
x [GenLocated
   SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
guarded' HsLocalBinds GhcTc
local_binds'
  where
    binders :: [IdP GhcTc]
binders = forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcTc
local_binds

addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
addTickCmdGRHS (GRHS XCGRHS GhcTc (LHsCmd GhcTc)
x [ExprLStmt GhcTc]
stmts LHsCmd GhcTc
cmd)
  = do { ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts',GenLocated SrcSpanAnnA (HsCmd GhcTc)
expr') <- forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CondBox -> Bool -> BoxLabel
BinBox forall a b. (a -> b) -> a -> b
$ CondBox
GuardBinBox)
                                   [ExprLStmt GhcTc]
stmts (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
cmd)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LHsCmd GhcTc)
x [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' GenLocated SrcSpanAnnA (HsCmd GhcTc)
expr' }

addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
addTickLCmdStmts :: [CmdLStmt GhcTc] -> TM [CmdLStmt GhcTc]
addTickLCmdStmts [CmdLStmt GhcTc]
stmts = do
  ([GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts, ()
_) <- forall a. [CmdLStmt GhcTc] -> TM a -> TM ([CmdLStmt GhcTc], a)
addTickLCmdStmts' [CmdLStmt GhcTc]
stmts (forall (m :: * -> *) a. Monad m => a -> m a
return ())
  forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts

addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
addTickLCmdStmts' :: forall a. [CmdLStmt GhcTc] -> TM a -> TM ([CmdLStmt GhcTc], a)
addTickLCmdStmts' [CmdLStmt GhcTc]
lstmts TM a
res
  = forall a. [Var] -> TM a -> TM a
bindLocals [IdP GhcTc]
binders forall a b. (a -> b) -> a -> b
$ do
        [GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
lstmts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b l.
Monad m =>
(a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
addTickCmdStmt) [CmdLStmt GhcTc]
lstmts
        a
a <- TM a
res
        forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
lstmts', a
a)
  where
        binders :: [IdP GhcTc]
binders = forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders forall p. CollectFlag p
CollNoDictBinders [CmdLStmt GhcTc]
lstmts

addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
addTickCmdStmt (BindStmt XBindStmt GhcTc GhcTc (LHsCmd GhcTc)
x LPat GhcTc
pat LHsCmd GhcTc
c) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTc GhcTc (LHsCmd GhcTc)
x)
                (LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
addTickCmdStmt (LastStmt XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
x LHsCmd GhcTc
c Maybe Bool
noret SyntaxExpr GhcTc
ret) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
x)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
noret)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
ret)
addTickCmdStmt (BodyStmt XBodyStmt GhcTc GhcTc (LHsCmd GhcTc)
x LHsCmd GhcTc
c SyntaxExpr GhcTc
bind' SyntaxExpr GhcTc
guard') =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LHsCmd GhcTc)
x)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bind')
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
guard')
addTickCmdStmt (LetStmt XLetStmt GhcTc GhcTc (LHsCmd GhcTc)
x HsLocalBinds GhcTc
binds) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcTc GhcTc (LHsCmd GhcTc)
x)
                (HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
binds)
addTickCmdStmt stmt :: Stmt GhcTc (LHsCmd GhcTc)
stmt@(RecStmt {})
  = do { [GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts' <- [CmdLStmt GhcTc] -> TM [CmdLStmt GhcTc]
addTickLCmdStmts (forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; SyntaxExprTc
ret'   <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; SyntaxExprTc
mfix'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; SyntaxExprTc
bind'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt GhcTc (LHsCmd GhcTc)
stmt { recS_stmts :: XRec
  GhcTc [LStmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
recS_stmts = forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
stmts', recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExprTc
ret'
                      , recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExprTc
mfix', recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExprTc
bind' }) }
addTickCmdStmt ApplicativeStmt{} =
  forall a. FilePath -> a
panic FilePath
"ToDo: addTickCmdStmt ApplicativeLastStmt"

-- Others should never happen in a command context.
addTickCmdStmt Stmt GhcTc (LHsCmd GhcTc)
stmt  = forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"addTickHsCmd" (forall a. Outputable a => a -> SDoc
ppr Stmt GhcTc (LHsCmd GhcTc)
stmt)

addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
addTickHsRecordBinds (HsRecFields [LHsRecField GhcTc (LHsExpr GhcTc)]
fields Maybe (Located Int)
dd)
  = do  { [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
fields' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall id.
LHsRecField' GhcTc id (LHsExpr GhcTc)
-> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))
addTickHsRecField [LHsRecField GhcTc (LHsExpr GhcTc)]
fields
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
fields' Maybe (Located Int)
dd) }

addTickHsRecField :: LHsRecField' GhcTc id (LHsExpr GhcTc)
                  -> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))
addTickHsRecField :: forall id.
LHsRecField' GhcTc id (LHsExpr GhcTc)
-> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))
addTickHsRecField (L SrcSpanAnnA
l (HsRecField XHsRecField id
x Located id
id GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr Bool
pun))
        = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr
             ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall id arg.
XHsRecField id -> Located id -> arg -> Bool -> HsRecField' id arg
HsRecField XHsRecField id
x Located id
id GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' Bool
pun)) }

addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo (From LHsExpr GhcTc
e1) =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall id. LHsExpr id -> ArithSeqInfo id
From
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
addTickArithSeqInfo (FromThen LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e2)
addTickArithSeqInfo (FromTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
        forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e2)
addTickArithSeqInfo (FromThenTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e2)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e3)

data TickTransState = TT { TickTransState -> Int
tickBoxCount:: !Int
                         , TickTransState -> [MixEntry_]
mixEntries  :: [MixEntry_]
                         , TickTransState -> CostCentreState
ccIndices   :: !CostCentreState
                         }

addMixEntry :: MixEntry_ -> TM Int
addMixEntry :: MixEntry_ -> TM Int
addMixEntry MixEntry_
ent = do
  Int
c <- TickTransState -> Int
tickBoxCount forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TM TickTransState
getState
  (TickTransState -> TickTransState) -> TM ()
setState forall a b. (a -> b) -> a -> b
$ \TickTransState
st ->
    TickTransState
st { tickBoxCount :: Int
tickBoxCount = Int
c forall a. Num a => a -> a -> a
+ Int
1
       , mixEntries :: [MixEntry_]
mixEntries = MixEntry_
ent forall a. a -> [a] -> [a]
: TickTransState -> [MixEntry_]
mixEntries TickTransState
st
       }
  forall (m :: * -> *) a. Monad m => a -> m a
return Int
c

data TickTransEnv = TTE { TickTransEnv -> FastString
fileName     :: FastString
                        , TickTransEnv -> TickDensity
density      :: TickDensity
                        , TickTransEnv -> DynFlags
tte_dflags   :: DynFlags
                        , TickTransEnv -> NameSet
exports      :: NameSet
                        , TickTransEnv -> VarSet
inlines      :: VarSet
                        , TickTransEnv -> [FilePath]
declPath     :: [String]
                        , TickTransEnv -> VarSet
inScope      :: VarSet
                        , TickTransEnv -> Set RealSrcSpan
blackList    :: Set RealSrcSpan
                        , TickTransEnv -> Module
this_mod     :: Module
                        , TickTransEnv -> TickishType
tickishType  :: TickishType
                        }

--      deriving Show

data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
                 deriving (TickishType -> TickishType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TickishType -> TickishType -> Bool
$c/= :: TickishType -> TickishType -> Bool
== :: TickishType -> TickishType -> Bool
$c== :: TickishType -> TickishType -> Bool
Eq)

coveragePasses :: DynFlags -> [TickishType]
coveragePasses :: DynFlags -> [TickishType]
coveragePasses DynFlags
dflags =
    forall {a}. Bool -> a -> [a] -> [a]
ifa (DynFlags -> Bool
breakpointsEnabled DynFlags
dflags)          TickishType
Breakpoints forall a b. (a -> b) -> a -> b
$
    forall {a}. Bool -> a -> [a] -> [a]
ifa (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc DynFlags
dflags)                TickishType
HpcTicks forall a b. (a -> b) -> a -> b
$
    forall {a}. Bool -> a -> [a] -> [a]
ifa (DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags Bool -> Bool -> Bool
&&
         DynFlags -> ProfAuto
profAuto DynFlags
dflags forall a. Eq a => a -> a -> Bool
/= ProfAuto
NoProfAuto)      TickishType
ProfNotes forall a b. (a -> b) -> a -> b
$
    forall {a}. Bool -> a -> [a] -> [a]
ifa (DynFlags -> Bool
needSourceNotes DynFlags
dflags)          TickishType
SourceNotes []
  where ifa :: Bool -> a -> [a] -> [a]
ifa Bool
f a
x [a]
xs | Bool
f         = a
xforall a. a -> [a] -> [a]
:[a]
xs
                   | Bool
otherwise = [a]
xs

-- | Should we produce 'Breakpoint' ticks?
breakpointsEnabled :: DynFlags -> Bool
breakpointsEnabled :: DynFlags -> Bool
breakpointsEnabled DynFlags
dflags = DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Backend
Interpreter

-- | Tickishs that only make sense when their source code location
-- refers to the current file. This might not always be true due to
-- LINE pragmas in the code - which would confuse at least HPC.
tickSameFileOnly :: TickishType -> Bool
tickSameFileOnly :: TickishType -> Bool
tickSameFileOnly TickishType
HpcTicks = Bool
True
tickSameFileOnly TickishType
_other   = Bool
False

type FreeVars = OccEnv Id
noFVs :: FreeVars
noFVs :: FreeVars
noFVs = forall a. OccEnv a
emptyOccEnv

-- Note [freevars]
--   For breakpoints we want to collect the free variables of an
--   expression for pinning on the HsTick.  We don't want to collect
--   *all* free variables though: in particular there's no point pinning
--   on free variables that are will otherwise be in scope at the GHCi
--   prompt, which means all top-level bindings.  Unfortunately detecting
--   top-level bindings isn't easy (collectHsBindsBinders on the top-level
--   bindings doesn't do it), so we keep track of a set of "in-scope"
--   variables in addition to the free variables, and the former is used
--   to filter additions to the latter.  This gives us complete control
--   over what free variables we track.

newtype TM a = TM { forall a.
TM a
-> TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
    deriving (forall a b. a -> TM b -> TM a
forall a b. (a -> b) -> TM a -> TM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TM b -> TM a
$c<$ :: forall a b. a -> TM b -> TM a
fmap :: forall a b. (a -> b) -> TM a -> TM b
$cfmap :: forall a b. (a -> b) -> TM a -> TM b
Functor)
        -- a combination of a state monad (TickTransState) and a writer
        -- monad (FreeVars).

instance Applicative TM where
    pure :: forall a. a -> TM a
pure a
a = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
_env TickTransState
st -> (a
a,FreeVars
noFVs,TickTransState
st)
    <*> :: forall a b. TM (a -> b) -> TM a -> TM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad TM where
  (TM TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m) >>= :: forall a b. TM a -> (a -> TM b) -> TM b
>>= a -> TM b
k = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st ->
                                case TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m TickTransEnv
env TickTransState
st of
                                  (a
r1,FreeVars
fv1,TickTransState
st1) ->
                                     case forall a.
TM a
-> TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
unTM (a -> TM b
k a
r1) TickTransEnv
env TickTransState
st1 of
                                       (b
r2,FreeVars
fv2,TickTransState
st2) ->
                                          (b
r2, FreeVars
fv1 forall a. OccEnv a -> OccEnv a -> OccEnv a
`plusOccEnv` FreeVars
fv2, TickTransState
st2)

instance HasDynFlags TM where
  getDynFlags :: TM DynFlags
getDynFlags = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st -> (TickTransEnv -> DynFlags
tte_dflags TickTransEnv
env, FreeVars
noFVs, TickTransState
st)

-- | Get the next HPC cost centre index for a given centre name
getCCIndexM :: FastString -> TM CostCentreIndex
getCCIndexM :: FastString -> TM CostCentreIndex
getCCIndexM FastString
n = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \TickTransEnv
_ TickTransState
st -> let (CostCentreIndex
idx, CostCentreState
is') = FastString -> CostCentreState -> (CostCentreIndex, CostCentreState)
getCCIndex FastString
n forall a b. (a -> b) -> a -> b
$
                                                 TickTransState -> CostCentreState
ccIndices TickTransState
st
                              in (CostCentreIndex
idx, FreeVars
noFVs, TickTransState
st { ccIndices :: CostCentreState
ccIndices = CostCentreState
is' })

getState :: TM TickTransState
getState :: TM TickTransState
getState = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
_ TickTransState
st -> (TickTransState
st, FreeVars
noFVs, TickTransState
st)

setState :: (TickTransState -> TickTransState) -> TM ()
setState :: (TickTransState -> TickTransState) -> TM ()
setState TickTransState -> TickTransState
f = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
_ TickTransState
st -> ((), FreeVars
noFVs, TickTransState -> TickTransState
f TickTransState
st)

getEnv :: TM TickTransEnv
getEnv :: TM TickTransEnv
getEnv = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st -> (TickTransEnv
env, FreeVars
noFVs, TickTransState
st)

withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv :: forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
f (TM TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m) = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st ->
                                 case TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m (TickTransEnv -> TickTransEnv
f TickTransEnv
env) TickTransState
st of
                                   (a
a, FreeVars
fvs, TickTransState
st') -> (a
a, FreeVars
fvs, TickTransState
st')

getDensity :: TM TickDensity
getDensity :: TM TickDensity
getDensity = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \TickTransEnv
env TickTransState
st -> (TickTransEnv -> TickDensity
density TickTransEnv
env, FreeVars
noFVs, TickTransState
st)

ifDensity :: TickDensity -> TM a -> TM a -> TM a
ifDensity :: forall a. TickDensity -> TM a -> TM a -> TM a
ifDensity TickDensity
d TM a
th TM a
el = do TickDensity
d0 <- TM TickDensity
getDensity; if TickDensity
d forall a. Eq a => a -> a -> Bool
== TickDensity
d0 then TM a
th else TM a
el

getFreeVars :: TM a -> TM (FreeVars, a)
getFreeVars :: forall a. TM a -> TM (FreeVars, a)
getFreeVars (TM TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m)
  = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st -> case TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m TickTransEnv
env TickTransState
st of (a
a, FreeVars
fv, TickTransState
st') -> ((FreeVars
fv,a
a), FreeVars
fv, TickTransState
st')

freeVar :: Id -> TM ()
freeVar :: Var -> TM ()
freeVar Var
id = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st ->
                if Var
id Var -> VarSet -> Bool
`elemVarSet` TickTransEnv -> VarSet
inScope TickTransEnv
env
                   then ((), forall a. OccName -> a -> OccEnv a
unitOccEnv (Name -> OccName
nameOccName (Var -> Name
idName Var
id)) Var
id, TickTransState
st)
                   else ((), FreeVars
noFVs, TickTransState
st)

addPathEntry :: String -> TM a -> TM a
addPathEntry :: forall a. FilePath -> TM a -> TM a
addPathEntry FilePath
nm = forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv (\ TickTransEnv
env -> TickTransEnv
env { declPath :: [FilePath]
declPath = TickTransEnv -> [FilePath]
declPath TickTransEnv
env forall a. [a] -> [a] -> [a]
++ [FilePath
nm] })

getPathEntry :: TM [String]
getPathEntry :: TM [FilePath]
getPathEntry = TickTransEnv -> [FilePath]
declPath forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TM TickTransEnv
getEnv

getFileName :: TM FastString
getFileName :: TM FastString
getFileName = TickTransEnv -> FastString
fileName forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TM TickTransEnv
getEnv

isGoodSrcSpan' :: SrcSpan -> Bool
isGoodSrcSpan' :: SrcSpan -> Bool
isGoodSrcSpan' pos :: SrcSpan
pos@(RealSrcSpan RealSrcSpan
_ Maybe BufSpan
_) = SrcSpan -> SrcLoc
srcSpanStart SrcSpan
pos forall a. Eq a => a -> a -> Bool
/= SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
pos
isGoodSrcSpan' (UnhelpfulSpan UnhelpfulSpanReason
_) = Bool
False

isGoodTickSrcSpan :: SrcSpan -> TM Bool
isGoodTickSrcSpan :: SrcSpan -> TM Bool
isGoodTickSrcSpan SrcSpan
pos = do
  FastString
file_name <- TM FastString
getFileName
  TickishType
tickish <- TickTransEnv -> TickishType
tickishType forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TM TickTransEnv
getEnv
  let need_same_file :: Bool
need_same_file = TickishType -> Bool
tickSameFileOnly TickishType
tickish
      same_file :: Bool
same_file      = forall a. a -> Maybe a
Just FastString
file_name forall a. Eq a => a -> a -> Bool
== SrcSpan -> Maybe FastString
srcSpanFileName_maybe SrcSpan
pos
  forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Bool
isGoodSrcSpan' SrcSpan
pos Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
need_same_file Bool -> Bool -> Bool
|| Bool
same_file))

ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan :: forall a. SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan SrcSpan
pos TM a
then_code TM a
else_code = do
  Bool
good <- SrcSpan -> TM Bool
isGoodTickSrcSpan SrcSpan
pos
  if Bool
good then TM a
then_code else TM a
else_code

bindLocals :: [Id] -> TM a -> TM a
bindLocals :: forall a. [Var] -> TM a -> TM a
bindLocals [Var]
new_ids (TM TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m)
  = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st ->
                 case TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m TickTransEnv
env{ inScope :: VarSet
inScope = TickTransEnv -> VarSet
inScope TickTransEnv
env VarSet -> [Var] -> VarSet
`extendVarSetList` [Var]
new_ids } TickTransState
st of
                   (a
r, FreeVars
fv, TickTransState
st') -> (a
r, FreeVars
fv forall a. OccEnv a -> [OccName] -> OccEnv a
`delListFromOccEnv` [OccName]
occs, TickTransState
st')
  where occs :: [OccName]
occs = [ Name -> OccName
nameOccName (Var -> Name
idName Var
id) | Var
id <- [Var]
new_ids ]

isBlackListed :: SrcSpan -> TM Bool
isBlackListed :: SrcSpan -> TM Bool
isBlackListed (RealSrcSpan RealSrcSpan
pos Maybe BufSpan
_) = forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st -> (forall a. Ord a => a -> Set a -> Bool
Set.member RealSrcSpan
pos (TickTransEnv -> Set RealSrcSpan
blackList TickTransEnv
env), FreeVars
noFVs, TickTransState
st)
isBlackListed (UnhelpfulSpan UnhelpfulSpanReason
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
             -> TM (LHsExpr GhcTc)
allocTickBox :: BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos TM (HsExpr GhcTc)
m =
  forall a. SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan SrcSpan
pos (do
    (FreeVars
fvs, HsExpr GhcTc
e) <- forall a. TM a -> TM (FreeVars, a)
getFreeVars TM (HsExpr GhcTc)
m
    TickTransEnv
env <- TM TickTransEnv
getEnv
    CoreTickish
tickish <- BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> FreeVars
-> [FilePath]
-> TM CoreTickish
mkTickish BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos FreeVars
fvs (TickTransEnv -> [FilePath]
declPath TickTransEnv
env)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
pos) (forall p. XTick p -> CoreTickish -> LHsExpr p -> HsExpr p
HsTick NoExtField
noExtField CoreTickish
tickish (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
pos) HsExpr GhcTc
e)))
  ) (do
    HsExpr GhcTc
e <- TM (HsExpr GhcTc)
m
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
pos) HsExpr GhcTc
e)
  )

-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
              -> TM (Maybe CoreTickish)
allocATickBox :: BoxLabel
-> Bool -> Bool -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
allocATickBox BoxLabel
boxLabel Bool
countEntries Bool
topOnly  SrcSpan
pos FreeVars
fvs =
  forall a. SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan SrcSpan
pos (do
    let
      mydecl_path :: [FilePath]
mydecl_path = case BoxLabel
boxLabel of
                      TopLevelBox [FilePath]
x -> [FilePath]
x
                      LocalBox [FilePath]
xs  -> [FilePath]
xs
                      BoxLabel
_ -> forall a. FilePath -> a
panic FilePath
"allocATickBox"
    CoreTickish
tickish <- BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> FreeVars
-> [FilePath]
-> TM CoreTickish
mkTickish BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos FreeVars
fvs [FilePath]
mydecl_path
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just CoreTickish
tickish)
  ) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)


mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
          -> TM CoreTickish
mkTickish :: BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> FreeVars
-> [FilePath]
-> TM CoreTickish
mkTickish BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos FreeVars
fvs [FilePath]
decl_path = do

  let ids :: [Var]
ids = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Bool
isUnliftedType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
idType) forall a b. (a -> b) -> a -> b
$ forall a. OccEnv a -> [a]
occEnvElts FreeVars
fvs
          -- unlifted types cause two problems here:
          --   * we can't bind them  at the GHCi prompt
          --     (bindLocalsAtBreakpoint already filters them out),
          --   * the simplifier might try to substitute a literal for
          --     the Id, and we can't handle that.

      me :: MixEntry_
me = (SrcSpan
pos, [FilePath]
decl_path, forall a b. (a -> b) -> [a] -> [b]
map (Name -> OccName
nameOccNameforall b c a. (b -> c) -> (a -> b) -> a -> c
.Var -> Name
idName) [Var]
ids, BoxLabel
boxLabel)

      cc_name :: FilePath
cc_name | Bool
topOnly   = forall a. [a] -> a
head [FilePath]
decl_path
              | Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse FilePath
"." [FilePath]
decl_path)

  DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  TickTransEnv
env <- TM TickTransEnv
getEnv
  case TickTransEnv -> TickishType
tickishType TickTransEnv
env of
    TickishType
HpcTicks -> forall (pass :: TickishPass). Module -> Int -> GenTickish pass
HpcTick (TickTransEnv -> Module
this_mod TickTransEnv
env) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MixEntry_ -> TM Int
addMixEntry MixEntry_
me

    TickishType
ProfNotes -> do
      let nm :: FastString
nm = FilePath -> FastString
mkFastString FilePath
cc_name
      CCFlavour
flavour <- CostCentreIndex -> CCFlavour
HpcCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> TM CostCentreIndex
getCCIndexM FastString
nm
      let cc :: CostCentre
cc = FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
nm (TickTransEnv -> Module
this_mod TickTransEnv
env) SrcSpan
pos CCFlavour
flavour
          count :: Bool
count = Bool
countEntries Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfCountEntries DynFlags
dflags
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
count Bool
True{-scopes-}

    TickishType
Breakpoints -> forall (pass :: TickishPass).
XBreakpoint pass -> Int -> [XTickishId pass] -> GenTickish pass
Breakpoint NoExtField
noExtField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MixEntry_ -> TM Int
addMixEntry MixEntry_
me forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Var]
ids

    TickishType
SourceNotes | RealSrcSpan RealSrcSpan
pos' Maybe BufSpan
_ <- SrcSpan
pos ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (pass :: TickishPass).
RealSrcSpan -> FilePath -> GenTickish pass
SourceNote RealSrcSpan
pos' FilePath
cc_name

    TickishType
_otherwise -> forall a. FilePath -> a
panic FilePath
"mkTickish: bad source span!"


allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
                -> TM (LHsExpr GhcTc)
allocBinTickBox :: (Bool -> BoxLabel)
-> SrcSpan -> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
allocBinTickBox Bool -> BoxLabel
boxLabel SrcSpan
pos TM (HsExpr GhcTc)
m = do
  TickTransEnv
env <- TM TickTransEnv
getEnv
  case TickTransEnv -> TickishType
tickishType TickTransEnv
env of
    TickishType
HpcTicks -> do GenLocated SrcSpanAnnA (HsExpr GhcTc)
e <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
pos)) TM (HsExpr GhcTc)
m
                   forall a. SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan SrcSpan
pos
                     ((Bool -> BoxLabel)
-> SrcSpan -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
mkBinTickBoxHpc Bool -> BoxLabel
boxLabel SrcSpan
pos GenLocated SrcSpanAnnA (HsExpr GhcTc)
e)
                     (forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcTc)
e)
    TickishType
_other   -> BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
False) Bool
False Bool
False SrcSpan
pos TM (HsExpr GhcTc)
m

mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
                -> TM (LHsExpr GhcTc)
mkBinTickBoxHpc :: (Bool -> BoxLabel)
-> SrcSpan -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
mkBinTickBoxHpc Bool -> BoxLabel
boxLabel SrcSpan
pos LHsExpr GhcTc
e = do
  TickTransEnv
env <- TM TickTransEnv
getEnv
  HsExpr GhcTc
binTick <- forall p. XBinTick p -> Int -> Int -> LHsExpr p -> HsExpr p
HsBinTick NoExtField
noExtField
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MixEntry_ -> TM Int
addMixEntry (SrcSpan
pos,TickTransEnv -> [FilePath]
declPath TickTransEnv
env, [],Bool -> BoxLabel
boxLabel Bool
True)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MixEntry_ -> TM Int
addMixEntry (SrcSpan
pos,TickTransEnv -> [FilePath]
declPath TickTransEnv
env, [],Bool -> BoxLabel
boxLabel Bool
False)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcTc
e
  CoreTickish
tick <- forall (pass :: TickishPass). Module -> Int -> GenTickish pass
HpcTick (TickTransEnv -> Module
this_mod TickTransEnv
env)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MixEntry_ -> TM Int
addMixEntry (SrcSpan
pos,TickTransEnv -> [FilePath]
declPath TickTransEnv
env, [],Bool -> BoxLabel
ExpBox Bool
False)
  let pos' :: SrcSpanAnnA
pos' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
pos
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos' forall a b. (a -> b) -> a -> b
$ forall p. XTick p -> CoreTickish -> LHsExpr p -> HsExpr p
HsTick NoExtField
noExtField CoreTickish
tick (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos' HsExpr GhcTc
binTick)

mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos :: SrcSpan
pos@(RealSrcSpan RealSrcSpan
s Maybe BufSpan
_)
   | SrcSpan -> Bool
isGoodSrcSpan' SrcSpan
pos = (Int, Int, Int, Int) -> HpcPos
toHpcPos (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s,
                                    RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s,
                                    RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s,
                                    RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s forall a. Num a => a -> a -> a
- Int
1)
                              -- the end column of a SrcSpan is one
                              -- greater than the last column of the
                              -- span (see SrcLoc), whereas HPC
                              -- expects to the column range to be
                              -- inclusive, hence we subtract one above.
mkHpcPos SrcSpan
_ = forall a. FilePath -> a
panic FilePath
"bad source span; expected such spans to be filtered out"

hpcSrcSpan :: SrcSpan
hpcSrcSpan :: SrcSpan
hpcSrcSpan = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"Haskell Program Coverage internals")

matchesOneOfMany :: [LMatch GhcTc body] -> Bool
matchesOneOfMany :: forall body. [LMatch GhcTc body] -> Bool
matchesOneOfMany [LMatch GhcTc body]
lmatches = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall body. LMatch GhcTc body -> Int
matchCount [LMatch GhcTc body]
lmatches) forall a. Ord a => a -> a -> Bool
> Int
1
  where
        matchCount :: LMatch GhcTc body -> Int
        matchCount :: forall body. LMatch GhcTc body -> Int
matchCount (L Anno (Match GhcTc body)
_ (Match { m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs XCGRHSs GhcTc body
_ [LGRHS GhcTc body]
grhss HsLocalBinds GhcTc
_ }))
          = forall (t :: * -> *) a. Foldable t => t a -> Int
length [LGRHS GhcTc body]
grhss

type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)

-- For the hash value, we hash everything: the file name,
--  the timestamp of the original source file, the tab stop,
--  and the mix entries. We cheat, and hash the show'd string.
-- This hash only has to be hashed at Mix creation time,
-- and is for sanity checking only.

mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
mixHash :: FilePath -> UTCTime -> Int -> [(HpcPos, BoxLabel)] -> Int
mixHash FilePath
file UTCTime
tm Int
tabstop [(HpcPos, BoxLabel)]
entries = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FilePath -> Int32
hashString
        (forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ FilePath -> UTCTime -> Hash -> Int -> [(HpcPos, BoxLabel)] -> Mix
Mix FilePath
file UTCTime
tm Hash
0 Int
tabstop [(HpcPos, BoxLabel)]
entries)

{-
************************************************************************
*                                                                      *
*              initialisation
*                                                                      *
************************************************************************

Each module compiled with -fhpc declares an initialisation function of
the form `hpc_init_<module>()`, which is emitted into the _stub.c file
and annotated with __attribute__((constructor)) so that it gets
executed at startup time.

The function's purpose is to call hs_hpc_module to register this
module with the RTS, and it looks something like this:

static void hpc_init_Main(void) __attribute__((constructor));
static void hpc_init_Main(void)
{extern StgWord64 _hpc_tickboxes_Main_hpc[];
 hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
-}

hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub
hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub
hpcInitCode DynFlags
_ Module
_ (NoHpcInfo {}) = forall a. Monoid a => a
mempty
hpcInitCode DynFlags
dflags Module
this_mod (HpcInfo Int
tickCount Int
hashNo)
 = SDoc -> CStub
CStub forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
    [ FilePath -> SDoc
text FilePath
"static void hpc_init_" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Module
this_mod
         SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"(void) __attribute__((constructor));"
    , FilePath -> SDoc
text FilePath
"static void hpc_init_" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"(void)"
    , SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat [
        FilePath -> SDoc
text FilePath
"extern StgWord64 " SDoc -> SDoc -> SDoc
<> SDoc
tickboxes SDoc -> SDoc -> SDoc
<>
               FilePath -> SDoc
text FilePath
"[]" SDoc -> SDoc -> SDoc
<> SDoc
semi,
        FilePath -> SDoc
text FilePath
"hs_hpc_module" SDoc -> SDoc -> SDoc
<>
          SDoc -> SDoc
parens ([SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [
              SDoc -> SDoc
doubleQuotes SDoc
full_name_str,
              Int -> SDoc
int Int
tickCount, -- really StgWord32
              Int -> SDoc
int Int
hashNo,    -- really StgWord32
              SDoc
tickboxes
            ])) SDoc -> SDoc -> SDoc
<> SDoc
semi
       ])
    ]
  where
    platform :: Platform
platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
    tickboxes :: SDoc
tickboxes = Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle (Module -> CLabel
mkHpcTicksLabel forall a b. (a -> b) -> a -> b
$ Module
this_mod)

    module_name :: SDoc
module_name  = [SDoc] -> SDoc
hcat (forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
textforall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack forall a b. (a -> b) -> a -> b
$
                         FastString -> ByteString
bytesFS (ModuleName -> FastString
moduleNameFS (forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)))
    package_name :: SDoc
package_name = [SDoc] -> SDoc
hcat (forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
textforall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack forall a b. (a -> b) -> a -> b
$
                         FastString -> ByteString
bytesFS (forall u. IsUnitId u => u -> FastString
unitFS  (forall unit. GenModule unit -> unit
moduleUnit Module
this_mod)))
    full_name_str :: SDoc
full_name_str
       | forall unit. GenModule unit -> unit
moduleUnit Module
this_mod forall a. Eq a => a -> a -> Bool
== Unit
mainUnit
       = SDoc
module_name
       | Bool
otherwise
       = SDoc
package_name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'/' SDoc -> SDoc -> SDoc
<> SDoc
module_name