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

{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}

module Coverage (addTicksToBinds, hpcInitCode) where

import GhcPrelude as Prelude

import qualified GHCi
import GHCi.RemoteTypes
import Data.Array
import ByteCodeTypes
import GHC.Stack.CCS
import Type
import GHC.Hs
import Module
import Outputable
import DynFlags
import ConLike
import Control.Monad
import SrcLoc
import ErrUtils
import NameSet hiding (FreeVars)
import Name
import Bag
import CostCentre
import CostCentreState
import CoreSyn
import Id
import VarSet
import Data.List
import FastString
import HscTypes
import TyCon
import BasicTypes
import MonadUtils
import Maybes
import CLabel
import Util

import Data.Time
import System.Directory

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

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

{-
************************************************************************
*                                                                      *
*              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 ([TickishType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TickishType]
passes),
    Just FilePath
orig_file <- ModLocation -> Maybe FilePath
ml_hs_file ModLocation
mod_loc,
    Bool -> Bool
not (FilePath
"boot" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
orig_file) = do

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

          tickPass :: TickishType
-> (LHsBinds GhcTc, TickTransState)
-> (LHsBinds GhcTc, TickTransState)
tickPass TickishType
tickish (LHsBinds GhcTc
binds,TickTransState
st) =
            let env :: TickTransEnv
env = TTE :: FastString
-> TickDensity
-> DynFlags
-> NameSet
-> VarSet
-> [FilePath]
-> VarSet
-> Map SrcSpan ()
-> Module
-> TickishType
-> TickTransEnv
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 :: Map SrcSpan ()
blackList    = [(SrcSpan, ())] -> Map SrcSpan ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                                          [ (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan (TyCon -> Name
tyConName TyCon
tyCon),())
                                          | TyCon
tyCon <- [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
                      }
                (LHsBinds GhcTc
binds',FreeVars
_,TickTransState
st') = TM (LHsBinds GhcTc)
-> TickTransEnv
-> TickTransState
-> (LHsBinds GhcTc, FreeVars, TickTransState)
forall a.
TM a
-> TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
unTM (LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds LHsBinds GhcTc
binds) TickTransEnv
env TickTransState
st
            in (LHsBinds GhcTc
binds', TickTransState
st')

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

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

     let tickCount :: Int
tickCount = TickTransState -> Int
tickBoxCount TickTransState
st
         entries :: [MixEntry_]
entries = [MixEntry_] -> [MixEntry_]
forall a. [a] -> [a]
reverse ([MixEntry_] -> [MixEntry_]) -> [MixEntry_] -> [MixEntry_]
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
     ModBreaks
modBreaks <- HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks HscEnv
hsc_env Module
mod Int
tickCount [MixEntry_]
entries

     DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_ticked FilePath
"HPC" (LHsBinds GhcTc -> SDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds LHsBinds GhcTc
binds1)

     (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
-> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
binds1, Int -> Int -> HpcInfo
HpcInfo Int
tickCount Int
hashNo, ModBreaks -> Maybe ModBreaks
forall a. a -> Maybe a
Just ModBreaks
modBreaks)

  | Bool
otherwise = (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
-> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
binds, Bool -> HpcInfo
emptyHpcInfo Bool
False, Maybe ModBreaks
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 = [Maybe FastString] -> [FastString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FastString] -> [FastString])
-> [Maybe FastString] -> [FastString]
forall a b. (a -> b) -> a -> b
$ (LHsBindLR GhcTc GhcTc -> [Maybe FastString] -> [Maybe FastString])
-> [Maybe FastString] -> LHsBinds GhcTc -> [Maybe FastString]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsBindLR GhcTc GhcTc)
_) [Maybe FastString]
rest ->
                                 SrcSpan -> Maybe FastString
srcSpanFileName_maybe SrcSpan
pos Maybe FastString -> [Maybe FastString] -> [Maybe FastString]
forall a. a -> [a] -> [a]
: [Maybe FastString]
rest) [] LHsBinds GhcTc
binds
     in
     case [FastString]
top_pos of
        (FastString
file_name:[FastString]
_) | FilePath
".hsc" FilePath -> FilePath -> Bool
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 ModBreaks
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks HscEnv
hsc_env Module
mod Int
count [MixEntry_]
entries
  | HscTarget
HscInterpreted <- DynFlags -> HscTarget
hscTarget (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) = do
    ForeignRef BreakArray
breakArray <- HscEnv -> Int -> IO (ForeignRef BreakArray)
GHCi.newBreakArray HscEnv
hsc_env ([MixEntry_] -> Int
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  = (Int, Int) -> [SrcSpan] -> Array Int SrcSpan
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [ SrcSpan
span  | (SrcSpan
span,[FilePath]
_,[OccName]
_,BoxLabel
_)  <- [MixEntry_]
entries ]
           varsTicks :: Array Int [OccName]
varsTicks  = (Int, Int) -> [[OccName]] -> Array Int [OccName]
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [ [OccName]
vars  | (SrcSpan
_,[FilePath]
_,[OccName]
vars,BoxLabel
_)  <- [MixEntry_]
entries ]
           declsTicks :: Array Int [FilePath]
declsTicks = (Int, Int) -> [[FilePath]] -> Array Int [FilePath]
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [ [FilePath]
decls | (SrcSpan
_,[FilePath]
decls,[OccName]
_,BoxLabel
_) <- [MixEntry_]
entries ]
    ModBreaks -> IO ModBreaks
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = ModBreaks -> IO ModBreaks
forall (m :: * -> *) a. Monad m => a -> m a
return ModBreaks
emptyModBreaks

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 = do
  if DynFlags -> Bool
interpreterProfiled DynFlags
dflags
    then do
      let module_str :: FilePath
module_str = ModuleName -> FilePath
moduleNameString (Module -> ModuleName
moduleName Module
modul)
      [RemotePtr CostCentre]
costcentres <- HscEnv
-> FilePath -> [(FilePath, FilePath)] -> IO [RemotePtr CostCentre]
GHCi.mkCostCentres HscEnv
hsc_env FilePath
module_str ((MixEntry_ -> (FilePath, FilePath))
-> [MixEntry_] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map MixEntry_ -> (FilePath, FilePath)
mk_one [MixEntry_]
entries)
      Array Int (RemotePtr CostCentre)
-> IO (Array Int (RemotePtr CostCentre))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Int)
-> [RemotePtr CostCentre] -> Array Int (RemotePtr CostCentre)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [RemotePtr CostCentre]
costcentres)
    else do
      Array Int (RemotePtr CostCentre)
-> IO (Array Int (RemotePtr CostCentre))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Int)
-> [RemotePtr CostCentre] -> Array Int (RemotePtr CostCentre)
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 = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"." [FilePath]
decl_path)
            src :: FilePath
src = DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SrcSpan -> SDoc
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) = Int -> IO Int
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 (Module -> ModuleName
moduleName Module
mod)

            hpc_mod_dir :: FilePath
hpc_mod_dir
              | Module -> UnitId
moduleUnitId Module
mod UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
mainUnitId  = FilePath
hpc_dir
              | Bool
otherwise = FilePath
hpc_dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnitId -> FilePath
unitIdString (Module -> UnitId
moduleUnitId 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] ]
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(HpcPos, BoxLabel)]
entries' [(HpcPos, BoxLabel)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIsNot` Int
count) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          FilePath -> IO ()
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
                       (Mix -> IO ()) -> Mix -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> UTCTime -> Hash -> Int -> [(HpcPos, BoxLabel)] -> Mix
Mix FilePath
filename UTCTime
modTime (Int -> Hash
forall a. HpcHash a => a -> Hash
toHash Int
hashNo) Int
tabStop [(HpcPos, BoxLabel)]
entries'
        Int -> IO Int
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
(TickDensity -> TickDensity -> Bool)
-> (TickDensity -> TickDensity -> Bool) -> Eq TickDensity
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           -> FilePath -> TickDensity
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 = (LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc))
-> LHsBinds GhcTc -> TM (LHsBinds GhcTc)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
addTickLHsBind

addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind :: LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
addTickLHsBind (LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos bind :: SrcSpanLess (LHsBindLR GhcTc GhcTc)
bind@(AbsBinds { abs_binds   = binds,
                                       abs_exports = abs_exports })) = do
  (TickTransEnv -> TickTransEnv)
-> TM (LHsBindLR GhcTc GhcTc) -> TM (LHsBindLR GhcTc GhcTc)
forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
add_exports (TM (LHsBindLR GhcTc GhcTc) -> TM (LHsBindLR GhcTc GhcTc))
-> TM (LHsBindLR GhcTc GhcTc) -> TM (LHsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ do
  (TickTransEnv -> TickTransEnv)
-> TM (LHsBindLR GhcTc GhcTc) -> TM (LHsBindLR GhcTc GhcTc)
forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
add_inlines (TM (LHsBindLR GhcTc GhcTc) -> TM (LHsBindLR GhcTc GhcTc))
-> TM (LHsBindLR GhcTc GhcTc) -> TM (LHsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ do
  LHsBinds GhcTc
binds' <- LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds LHsBinds GhcTc
binds
  LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc))
-> LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos (SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc)
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBindLR GhcTc GhcTc
bind { abs_binds :: LHsBinds GhcTc
abs_binds = LHsBinds 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`
                      [ Id -> Name
idName Id
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
                      , Id -> Name
idName Id
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 -> [Id] -> VarSet
`extendVarSetList`
                      [ Id
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 (Id -> InlinePragma
idInlinePragma Id
IdP GhcTc
pid) ] }

addTickLHsBind (LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos (funBind :: SrcSpanLess (LHsBindLR GhcTc GhcTc)
funBind@(FunBind { fun_id = (dL->L _ id)  }))) = do
  let name :: FilePath
name = Id -> FilePath
forall a. NamedThing a => a -> FilePath
getOccString SrcSpanLess (Located Id)
Id
id
  [FilePath]
decl_path <- TM [FilePath]
getPathEntry
  TickDensity
density <- TM TickDensity
getDensity

  VarSet
inline_ids <- (TickTransEnv -> VarSet) -> TM TickTransEnv -> TM VarSet
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 (Id -> InlinePragma
idInlinePragma SrcSpanLess (Located Id)
Id
id)
                 Bool -> Bool -> Bool
|| SrcSpanLess (Located Id)
Id
id Id -> VarSet -> Bool
`elemVarSet` VarSet
inline_ids

  -- See Note [inline sccs]
  TickishType
tickish <- TickTransEnv -> TickishType
tickishType (TickTransEnv -> TickishType) -> TM TickTransEnv -> TM 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 TickishType -> TickishType -> Bool
forall a. Eq a => a -> a -> Bool
== TickishType
ProfNotes then LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsBindLR GhcTc GhcTc)
funBind) else do

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

  case MatchGroup GhcTc (LHsExpr GhcTc)
mg of
    MG {} -> () -> TM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    MatchGroup GhcTc (LHsExpr GhcTc)
_     -> FilePath -> TM ()
forall a. FilePath -> a
panic FilePath
"addTickLHsBind"

  Bool
blackListed <- SrcSpan -> TM Bool
isBlackListed SrcSpan
pos
  NameSet
exported_names <- (TickTransEnv -> NameSet) -> TM TickTransEnv -> TM NameSet
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 SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBindLR GhcTc GhcTc
funBind
      toplev :: Bool
toplev = [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
decl_path
      exported :: Bool
exported = Id -> Name
idName SrcSpanLess (Located Id)
Id
id Name -> NameSet -> Bool
`elemNameSet` NameSet
exported_names

  Maybe (Tickish Id)
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 (Tickish Id))
bindTick TickDensity
density FilePath
name SrcSpan
pos FreeVars
fvs
             else
                Maybe (Tickish Id) -> TM (Maybe (Tickish Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tickish Id)
forall a. Maybe a
Nothing

  let mbCons :: Maybe a -> [a] -> [a]
mbCons = ([a] -> [a]) -> (a -> [a] -> [a]) -> Maybe a -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
Prelude.id (:)
  LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc))
-> LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos (SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc)
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBindLR GhcTc GhcTc
funBind { fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
mg
                            , fun_tick :: [Tickish Id]
fun_tick = Maybe (Tickish Id)
tick Maybe (Tickish Id) -> [Tickish Id] -> [Tickish Id]
forall a. Maybe a -> [a] -> [a]
`mbCons` HsBindLR GhcTc GhcTc -> [Tickish Id]
forall idL idR. HsBindLR idL idR -> [Tickish Id]
fun_tick SrcSpanLess (LHsBindLR GhcTc GhcTc)
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 = MatchGroup GhcTc (LHsExpr GhcTc) -> Int
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Int
matchGroupArity (HsBindLR GhcTc GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc)
forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches HsBindLR GhcTc GhcTc
funBind) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

-- TODO: Revisit this
addTickLHsBind (LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos (pat :: SrcSpanLess (LHsBindLR GhcTc GhcTc)
pat@(PatBind { pat_lhs = lhs
                                        , pat_rhs = rhs }))) = do
  let name :: FilePath
name = FilePath
"(...)"
  (FreeVars
fvs, GRHSs GhcTc (LHsExpr GhcTc)
rhs') <- TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (FreeVars, GRHSs GhcTc (LHsExpr GhcTc))
forall a. TM a -> TM (FreeVars, a)
getFreeVars (TM (GRHSs GhcTc (LHsExpr GhcTc))
 -> TM (FreeVars, GRHSs GhcTc (LHsExpr GhcTc)))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (FreeVars, GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ FilePath
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. FilePath -> TM a -> TM a
addPathEntry FilePath
name (TM (GRHSs GhcTc (LHsExpr GhcTc))
 -> TM (GRHSs GhcTc (LHsExpr GhcTc)))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
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' = SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBindLR GhcTc GhcTc
pat { pat_rhs :: GRHSs GhcTc (LHsExpr GhcTc)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
rhs'}

  -- Should create ticks here?
  TickDensity
density <- TM TickDensity
getDensity
  [FilePath]
decl_path <- TM [FilePath]
getPathEntry
  let top_lev :: Bool
top_lev = [FilePath] -> Bool
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 LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBindLR GhcTc GhcTc
pat')
    else do

    -- Allocate the ticks
    Maybe (Tickish Id)
rhs_tick <- TickDensity
-> FilePath -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
bindTick TickDensity
density FilePath
name SrcSpan
pos FreeVars
fvs
    let patvars :: [FilePath]
patvars = (Id -> FilePath) -> [Id] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Id -> FilePath
forall a. NamedThing a => a -> FilePath
getOccString (LPat GhcTc -> [IdP GhcTc]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcTc
lhs)
    [Maybe (Tickish Id)]
patvar_ticks <- (FilePath -> TM (Maybe (Tickish Id)))
-> [FilePath] -> TM [Maybe (Tickish Id)]
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 (Tickish Id))
bindTick TickDensity
density FilePath
v SrcSpan
pos FreeVars
fvs) [FilePath]
patvars

    -- Add to pattern
    let mbCons :: Maybe a -> [a] -> [a]
mbCons = ([a] -> [a]) -> (a -> [a] -> [a]) -> Maybe a -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id (:)
        rhs_ticks :: [Tickish Id]
rhs_ticks = Maybe (Tickish Id)
rhs_tick Maybe (Tickish Id) -> [Tickish Id] -> [Tickish Id]
forall a. Maybe a -> [a] -> [a]
`mbCons` ([Tickish Id], [[Tickish Id]]) -> [Tickish Id]
forall a b. (a, b) -> a
fst (HsBindLR GhcTc GhcTc -> ([Tickish Id], [[Tickish Id]])
forall idL idR. HsBindLR idL idR -> ([Tickish Id], [[Tickish Id]])
pat_ticks HsBindLR GhcTc GhcTc
pat')
        patvar_tickss :: [[Tickish Id]]
patvar_tickss = (Maybe (Tickish Id) -> [Tickish Id] -> [Tickish Id])
-> [Maybe (Tickish Id)] -> [[Tickish Id]] -> [[Tickish Id]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe (Tickish Id) -> [Tickish Id] -> [Tickish Id]
forall a. Maybe a -> [a] -> [a]
mbCons [Maybe (Tickish Id)]
patvar_ticks
                        (([Tickish Id], [[Tickish Id]]) -> [[Tickish Id]]
forall a b. (a, b) -> b
snd (HsBindLR GhcTc GhcTc -> ([Tickish Id], [[Tickish Id]])
forall idL idR. HsBindLR idL idR -> ([Tickish Id], [[Tickish Id]])
pat_ticks HsBindLR GhcTc GhcTc
pat') [[Tickish Id]] -> [[Tickish Id]] -> [[Tickish Id]]
forall a. [a] -> [a] -> [a]
++ [Tickish Id] -> [[Tickish Id]]
forall a. a -> [a]
repeat [])
    LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc))
-> LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos (SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc)
-> SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$ HsBindLR GhcTc GhcTc
pat' { pat_ticks :: ([Tickish Id], [[Tickish Id]])
pat_ticks = ([Tickish Id]
rhs_ticks, [[Tickish Id]]
patvar_tickss) }

-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind :: LHsBindLR GhcTc GhcTc
var_bind@(LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (VarBind {})) = LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBindLR GhcTc GhcTc
var_bind
addTickLHsBind patsyn_bind :: LHsBindLR GhcTc GhcTc
patsyn_bind@(LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatSynBind {})) = LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBindLR GhcTc GhcTc
patsyn_bind
addTickLHsBind bind :: LHsBindLR GhcTc GhcTc
bind@(LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XHsBindsLR {})) = LHsBindLR GhcTc GhcTc -> TM (LHsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBindLR GhcTc GhcTc
bind
addTickLHsBind LHsBindLR GhcTc GhcTc
_  = FilePath -> TM (LHsBindLR GhcTc GhcTc)
forall a. FilePath -> a
panic FilePath
"addTickLHsBind: Impossible Match" -- due to #15884



bindTick
  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
bindTick :: TickDensity
-> FilePath -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
bindTick TickDensity
density FilePath
name SrcSpan
pos FreeVars
fvs = do
  [FilePath]
decl_path <- TM [FilePath]
getPathEntry
  let
      toplev :: Bool
toplev        = [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
decl_path
      count_entries :: Bool
count_entries = Bool
toplev Bool -> Bool -> Bool
|| TickDensity
density TickDensity -> TickDensity -> Bool
forall a. Eq a => a -> a -> Bool
== TickDensity
TickAllFunctions
      top_only :: Bool
top_only      = TickDensity
density TickDensity -> TickDensity -> Bool
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 [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
name])
  --
  BoxLabel
-> Bool -> Bool -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
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@(LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0) = do
  TickDensity
d <- TM TickDensity
getDensity
  case TickDensity
d of
    TickDensity
TickForBreakPoints | HsExpr GhcTc -> Bool
isGoodBreakExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e0 -> TM (LHsExpr GhcTc)
tick_it
    TickDensity
TickForCoverage    -> TM (LHsExpr GhcTc)
tick_it
    TickDensity
TickCallSites      | HsExpr GhcTc -> Bool
isCallSite SrcSpanLess (LHsExpr GhcTc)
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 SrcSpan
pos (TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
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@(LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0) = do
  TickDensity
d <- TM TickDensity
getDensity
  case TickDensity
d of
     TickDensity
TickForBreakPoints | HsLet{} <- SrcSpanLess (LHsExpr 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 SrcSpanLess (LHsExpr GhcTc)
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 SrcSpan
pos (TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
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@(LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0) = do
  TickDensity
d <- TM TickDensity
getDensity
  case TickDensity
d of
     TickDensity
TickForBreakPoints | HsLet{} <- SrcSpanLess (LHsExpr 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 SrcSpan
pos (TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
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 (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0) = do
    HsExpr GhcTc
e1 <- HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e0
    LHsExpr GhcTc -> TM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTc -> TM (LHsExpr GhcTc))
-> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e1

-- general heuristic: expressions which do not denote values are good
-- break points
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr (HsApp {})     = Bool
True
isGoodBreakExpr (HsAppType {}) = Bool
True
isGoodBreakExpr (OpApp {})     = Bool
True
isGoodBreakExpr HsExpr GhcTc
_other         = Bool
False

isCallSite :: HsExpr GhcTc -> Bool
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{}     = Bool
True
isCallSite HsAppType{} = Bool
True
isCallSite OpApp{}     = Bool
True
isCallSite HsExpr GhcTc
_ = Bool
False

addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
oneOfMany (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0)
  = TickDensity
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc)
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 SrcSpan
pos (TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e0)
        (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0))

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr Bool -> BoxLabel
boxLabel (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0)
  = TickDensity
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc)
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 SrcSpan
pos (TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e0)
        (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsExpr 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
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located Id))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Id)
id)) = do Id -> TM ()
freeVar SrcSpanLess (Located Id)
Id
id; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr (HsUnboundVar {})    = FilePath -> TM (HsExpr GhcTc)
forall a. FilePath -> a
panic FilePath
"addTickHsExpr.HsUnboundVar"
addTickHsExpr e :: HsExpr GhcTc
e@(HsConLikeOut XConLikeOut GhcTc
_ ConLike
con)
  | Just Id
id <- ConLike -> Maybe Id
conLikeWrapId_maybe ConLike
con = do Id -> TM ()
freeVar Id
id; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsIPVar {})       = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsOverLit {})     = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsOverLabel{})    = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsLit {})         = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr (HsLam XLam GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
matchgroup) = (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
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)
matchgroup)
addTickHsExpr (HsLamCase XLamCase GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
mgs)    = (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XLamCase GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
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)      = (LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
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)   = (NoExtField
 -> LHsExpr GhcTc -> LHsWcType (GhcPass 'Renamed) -> HsExpr GhcTc)
-> TM NoExtField
-> TM (LHsExpr GhcTc)
-> TM (LHsWcType (GhcPass 'Renamed))
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 NoExtField
-> LHsExpr GhcTc -> LHsWcType (GhcPass 'Renamed) -> HsExpr GhcTc
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType (NoExtField -> TM NoExtField
forall (m :: * -> *) a. Monad m => a -> m a
return XAppTypeE GhcTc
NoExtField
x)
                                                      (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e)
                                                      (LHsWcType (GhcPass 'Renamed) -> TM (LHsWcType (GhcPass 'Renamed))
forall (m :: * -> *) a. Monad m => a -> m a
return LHsWcType (NoGhcTc GhcTc)
LHsWcType (GhcPass 'Renamed)
ty)

addTickHsExpr (OpApp XOpApp GhcTc
fix LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) =
        (Fixity
 -> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM Fixity
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (HsExpr GhcTc)
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 Fixity
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp
                (Fixity -> TM Fixity
forall (m :: * -> *) a. Monad m => a -> m a
return Fixity
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) =
        (LHsExpr GhcTc -> SyntaxExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (SyntaxExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XNegApp GhcTc -> LHsExpr GhcTc -> SyntaxExpr GhcTc -> HsExpr GhcTc
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) =
        (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
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) =
        (LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XSectionL GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
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) =
        (LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XSectionR GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
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 [LHsTupArg GhcTc]
es Boxity
boxity) =
        ([LHsTupArg GhcTc] -> Boxity -> HsExpr GhcTc)
-> TM [LHsTupArg GhcTc] -> TM Boxity -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XExplicitTuple GhcTc -> [LHsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcTc
x)
                ((LHsTupArg GhcTc -> TM (LHsTupArg GhcTc))
-> [LHsTupArg GhcTc] -> TM [LHsTupArg GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
addTickTupArg [LHsTupArg GhcTc]
es)
                (Boxity -> TM Boxity
forall (m :: * -> *) a. Monad m => a -> m a
return Boxity
boxity)
addTickHsExpr (ExplicitSum XExplicitSum GhcTc
ty Int
tag Int
arity LHsExpr GhcTc
e) = do
        LHsExpr GhcTc
e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
        HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitSum GhcTc -> Int -> Int -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcTc
ty Int
tag Int
arity LHsExpr GhcTc
e')
addTickHsExpr (HsCase XCase GhcTc
x LHsExpr GhcTc
e MatchGroup GhcTc (LHsExpr GhcTc)
mgs) =
        (LHsExpr GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
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 Maybe (SyntaxExpr GhcTc)
cnd LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) =
        (LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XIf GhcTc
-> Maybe (SyntaxExpr GhcTc)
-> LHsExpr GhcTc
-> LHsExpr GhcTc
-> LHsExpr GhcTc
-> HsExpr GhcTc
forall p.
XIf p
-> Maybe (SyntaxExpr p)
-> LHsExpr p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsIf XIf GhcTc
x Maybe (SyntaxExpr GhcTc)
cnd)
                ((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
       ; [LGRHS GhcTc (LHsExpr GhcTc)]
alts' <- (LGRHS GhcTc (LHsExpr GhcTc) -> TM (LGRHS GhcTc (LHsExpr GhcTc)))
-> [LGRHS GhcTc (LHsExpr GhcTc)]
-> TM [LGRHS GhcTc (LHsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))
 -> TM (SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))))
-> LGRHS GhcTc (LHsExpr GhcTc) -> TM (LGRHS GhcTc (LHsExpr GhcTc))
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL ((SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))
  -> TM (SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))))
 -> LGRHS GhcTc (LHsExpr GhcTc) -> TM (LGRHS GhcTc (LHsExpr GhcTc)))
-> (SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))
    -> TM (SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))))
-> LGRHS GhcTc (LHsExpr GhcTc)
-> TM (LGRHS GhcTc (LHsExpr GhcTc))
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
       ; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TM (HsExpr GhcTc))
-> HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XMultiIf GhcTc -> [LGRHS GhcTc (LHsExpr GhcTc)] -> HsExpr GhcTc
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf XMultiIf GhcTc
ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts' }
addTickHsExpr (HsLet XLet GhcTc
x (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
binds) LHsExpr GhcTc
e) =
        [Id] -> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a. [Id] -> TM a -> TM a
bindLocals (HsLocalBindsLR GhcTc GhcTc -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass).
HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectLocalBinders SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
binds) (TM (HsExpr GhcTc) -> TM (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
          (HsLocalBindsLR GhcTc GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (HsLocalBindsLR GhcTc GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XLet GhcTc -> LHsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcTc
x (LHsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc)
-> (HsLocalBindsLR GhcTc GhcTc -> LHsLocalBinds GhcTc)
-> HsLocalBindsLR GhcTc GhcTc
-> LHsExpr GhcTc
-> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcSpanLess (LHsLocalBinds GhcTc) -> LHsLocalBinds GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l)
                  (HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
addTickHsLocalBinds SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
binds) -- to think about: !patterns.
                  (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprLetBody LHsExpr GhcTc
e)
addTickHsExpr (HsDo XDo GhcTc
srcloc HsStmtContext Name
cxt (Located [ExprLStmt GhcTc]
-> Located (SrcSpanLess (Located [ExprLStmt GhcTc]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located [ExprLStmt GhcTc])
stmts))
  = do { ([ExprLStmt GhcTc]
stmts', ()
_) <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM () -> TM ([ExprLStmt GhcTc], ())
forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' Maybe (Bool -> BoxLabel)
forQual [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts (() -> TM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTc
-> HsStmtContext Name -> Located [ExprLStmt GhcTc] -> HsExpr GhcTc
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
srcloc HsStmtContext Name
cxt (SrcSpan
-> SrcSpanLess (Located [ExprLStmt GhcTc])
-> Located [ExprLStmt GhcTc]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts')) }
  where
        forQual :: Maybe (Bool -> BoxLabel)
forQual = case HsStmtContext Name
cxt of
                    HsStmtContext Name
ListComp -> (Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel)
forall a. a -> Maybe a
Just ((Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel))
-> (Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel)
forall a b. (a -> b) -> a -> b
$ CondBox -> Bool -> BoxLabel
BinBox CondBox
QualBinBox
                    HsStmtContext Name
_        -> Maybe (Bool -> BoxLabel)
forall a. Maybe a
Nothing
addTickHsExpr (ExplicitList XExplicitList GhcTc
ty Maybe (SyntaxExpr GhcTc)
wit [LHsExpr GhcTc]
es) =
        (Type
 -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> HsExpr GhcTc)
-> TM Type
-> TM (Maybe (SyntaxExpr GhcTc))
-> TM [LHsExpr GhcTc]
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList
                (Type -> TM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
XExplicitList GhcTc
ty)
                (Maybe (SyntaxExpr GhcTc) -> TM (Maybe (SyntaxExpr GhcTc))
addTickWit Maybe (SyntaxExpr GhcTc)
wit)
                ((LHsExpr GhcTc -> TM (LHsExpr GhcTc))
-> [LHsExpr GhcTc] -> TM [LHsExpr GhcTc]
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)
             where addTickWit :: Maybe (SyntaxExpr GhcTc) -> TM (Maybe (SyntaxExpr GhcTc))
addTickWit Maybe (SyntaxExpr GhcTc)
Nothing = Maybe (SyntaxExpr GhcTc) -> TM (Maybe (SyntaxExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing
                   addTickWit (Just SyntaxExpr GhcTc
fln)
                     = do SyntaxExpr GhcTc
fln' <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
fln
                          Maybe (SyntaxExpr GhcTc) -> TM (Maybe (SyntaxExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcTc -> Maybe (SyntaxExpr GhcTc)
forall a. a -> Maybe a
Just SyntaxExpr GhcTc
fln')

addTickHsExpr (HsStatic XStatic GhcTc
fvs LHsExpr GhcTc
e) = XStatic GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcTc
fvs (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
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 { HsRecordBinds GhcTc
rec_binds' <- HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
addTickHsRecordBinds HsRecordBinds GhcTc
rec_binds
       ; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr { rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecordBinds 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 -> [LHsRecUpdField p]
rupd_flds = [LHsRecUpdField GhcTc]
flds })
  = do { LHsExpr GhcTc
e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
       ; [LHsRecUpdField GhcTc]
flds' <- (LHsRecUpdField GhcTc -> TM (LHsRecUpdField GhcTc))
-> [LHsRecUpdField GhcTc] -> TM [LHsRecUpdField GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcTc -> TM (LHsRecUpdField GhcTc)
forall id.
LHsRecField' id (LHsExpr GhcTc)
-> TM (LHsRecField' id (LHsExpr GhcTc))
addTickHsRecField [LHsRecUpdField GhcTc]
flds
       ; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr { rupd_expr :: LHsExpr GhcTc
rupd_expr = LHsExpr GhcTc
e', rupd_flds :: [LHsRecUpdField GhcTc]
rupd_flds = [LHsRecUpdField GhcTc]
flds' }) }

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

-- We might encounter existing ticks (multiple Coverage passes)
addTickHsExpr (HsTick XTick GhcTc
x Tickish (IdP GhcTc)
t LHsExpr GhcTc
e) =
        (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XTick GhcTc -> Tickish (IdP GhcTc) -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XTick p -> Tickish (IdP p) -> LHsExpr p -> HsExpr p
HsTick XTick GhcTc
x Tickish (IdP GhcTc)
t) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e)
addTickHsExpr (HsBinTick XBinTick GhcTc
x Int
t0 Int
t1 LHsExpr GhcTc
e) =
        (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XBinTick GhcTc -> Int -> Int -> LHsExpr GhcTc -> HsExpr GhcTc
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 (HsTickPragma XTickPragma GhcTc
_ SourceText
_ (StringLiteral, (Int, Int), (Int, Int))
_ ((SourceText, SourceText), (SourceText, SourceText))
_ (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
e0)) = do
    LHsExpr GhcTc
e2 <- 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) -> TM (LHsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e0
    HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TM (HsExpr GhcTc))
-> HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> SrcSpanLess (LHsExpr GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcTc
e2
addTickHsExpr (HsSCC XSCC GhcTc
x SourceText
src StringLiteral
nm LHsExpr GhcTc
e) =
        (SourceText -> StringLiteral -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM SourceText
-> TM StringLiteral
-> TM (LHsExpr GhcTc)
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XSCC GhcTc
-> SourceText -> StringLiteral -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XSCC p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsSCC XSCC GhcTc
x)
                (SourceText -> TM SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return SourceText
src)
                (StringLiteral -> TM StringLiteral
forall (m :: * -> *) a. Monad m => a -> m a
return StringLiteral
nm)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
addTickHsExpr (HsCoreAnn XCoreAnn GhcTc
x SourceText
src StringLiteral
nm LHsExpr GhcTc
e) =
        (SourceText -> StringLiteral -> LHsExpr GhcTc -> HsExpr GhcTc)
-> TM SourceText
-> TM StringLiteral
-> TM (LHsExpr GhcTc)
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XCoreAnn GhcTc
-> SourceText -> StringLiteral -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XCoreAnn p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsCoreAnn XCoreAnn GhcTc
x)
                (SourceText -> TM SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return SourceText
src)
                (StringLiteral -> TM StringLiteral
forall (m :: * -> *) a. Monad m => a -> m a
return StringLiteral
nm)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
addTickHsExpr e :: HsExpr GhcTc
e@(HsBracket     {})   = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsTcBracketOut  {}) = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsRnBracketOut  {}) = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsSpliceE  {})      = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr (HsProc XProc GhcTc
x LPat GhcTc
pat LHsCmdTop GhcTc
cmdtop) =
        (Located (Pat GhcTc) -> LHsCmdTop GhcTc -> HsExpr GhcTc)
-> TM (Located (Pat GhcTc))
-> TM (LHsCmdTop GhcTc)
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XProc GhcTc -> LPat GhcTc -> LHsCmdTop GhcTc -> HsExpr GhcTc
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcTc
x)
                (LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat)
                ((SrcSpanLess (LHsCmdTop GhcTc)
 -> TM (SrcSpanLess (LHsCmdTop GhcTc)))
-> LHsCmdTop GhcTc -> TM (LHsCmdTop GhcTc)
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL (SrcSpanLess (LHsCmdTop GhcTc) -> TM (SrcSpanLess (LHsCmdTop GhcTc))
HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop) LHsCmdTop GhcTc
cmdtop)
addTickHsExpr (HsWrap XWrap GhcTc
x HsWrapper
w HsExpr GhcTc
e) =
        (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> TM HsWrapper -> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XWrap GhcTc -> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall p. XWrap p -> HsWrapper -> HsExpr p -> HsExpr p
HsWrap XWrap GhcTc
x)
                (HsWrapper -> TM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
w)
                (HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e)       -- Explicitly no tick on inside

-- Others should never happen in expression content.
addTickHsExpr HsExpr GhcTc
e  = FilePath -> SDoc -> TM (HsExpr GhcTc)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"addTickHsExpr" (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)

addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
addTickTupArg (LHsTupArg GhcTc -> Located (SrcSpanLess (LHsTupArg GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (Present x e))  = do { LHsExpr GhcTc
e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
                                            ; LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsTupArg GhcTc) -> LHsTupArg GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XPresent GhcTc -> LHsExpr GhcTc -> HsTupArg GhcTc
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcTc
x LHsExpr GhcTc
e')) }
addTickTupArg (LHsTupArg GhcTc -> Located (SrcSpanLess (LHsTupArg GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (Missing ty)) = LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsTupArg GhcTc) -> LHsTupArg GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XMissing GhcTc -> HsTupArg GhcTc
forall id. XMissing id -> HsTupArg id
Missing XMissing GhcTc
ty))
addTickTupArg (LHsTupArg GhcTc -> Located (SrcSpanLess (LHsTupArg GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XTupArg nec)) = NoExtCon -> TM (LHsTupArg GhcTc)
forall a. NoExtCon -> a
noExtCon XXTupArg GhcTc
NoExtCon
nec
addTickTupArg LHsTupArg GhcTc
_  = FilePath -> TM (LHsTupArg GhcTc)
forall a. FilePath -> a
panic FilePath
"addTickTupArg: Impossible Match" -- due to #15884


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 -> Located [LMatch p body]
mg_alts = Located [LMatch GhcTc (LHsExpr GhcTc)]
-> Located (SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
matches }) = do
  let isOneOfMany :: Bool
isOneOfMany = [LMatch GhcTc (LHsExpr GhcTc)] -> Bool
forall body. [LMatch GhcTc body] -> Bool
matchesOneOfMany [LMatch GhcTc (LHsExpr GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
matches
  [LMatch GhcTc (LHsExpr GhcTc)]
matches' <- (LMatch GhcTc (LHsExpr GhcTc) -> TM (LMatch GhcTc (LHsExpr GhcTc)))
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> TM [LMatch GhcTc (LHsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LMatch GhcTc (LHsExpr GhcTc))
 -> TM (SrcSpanLess (LMatch GhcTc (LHsExpr GhcTc))))
-> LMatch GhcTc (LHsExpr GhcTc)
-> TM (LMatch GhcTc (LHsExpr GhcTc))
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL (Bool
-> Bool
-> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch Bool
isOneOfMany Bool
is_lam)) [LMatch GhcTc (LHsExpr GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
matches
  MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcTc (LHsExpr GhcTc)
 -> TM (MatchGroup GhcTc (LHsExpr GhcTc)))
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcTc (LHsExpr GhcTc)
mg { mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = SrcSpan
-> SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [LMatch GhcTc (LHsExpr GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
matches' }
addTickMatchGroup Bool
_ (XMatchGroup XXMatchGroup GhcTc (LHsExpr GhcTc)
nec) = NoExtCon -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
forall a. NoExtCon -> a
noExtCon XXMatchGroup GhcTc (LHsExpr GhcTc)
NoExtCon
nec

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 }) =
  [Id]
-> TM (Match GhcTc (LHsExpr GhcTc))
-> TM (Match GhcTc (LHsExpr GhcTc))
forall a. [Id] -> TM a -> TM a
bindLocals ([LPat GhcTc] -> [IdP GhcTc]
forall (p :: Pass). [LPat (GhcPass p)] -> [IdP (GhcPass p)]
collectPatsBinders [LPat GhcTc]
pats) (TM (Match GhcTc (LHsExpr GhcTc))
 -> TM (Match GhcTc (LHsExpr GhcTc)))
-> TM (Match GhcTc (LHsExpr GhcTc))
-> TM (Match GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ do
    GRHSs GhcTc (LHsExpr GhcTc)
gRHSs' <- Bool
-> Bool
-> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs Bool
isOneOfMany Bool
isLambda GRHSs GhcTc (LHsExpr GhcTc)
gRHSs
    Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)))
-> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ Match GhcTc (LHsExpr GhcTc)
match { m_grhss :: GRHSs GhcTc (LHsExpr GhcTc)
m_grhss = GRHSs GhcTc (LHsExpr GhcTc)
gRHSs' }
addTickMatch Bool
_ Bool
_ (XMatch XXMatch GhcTc (LHsExpr GhcTc)
nec) = NoExtCon -> TM (Match GhcTc (LHsExpr GhcTc))
forall a. NoExtCon -> a
noExtCon XXMatch GhcTc (LHsExpr GhcTc)
NoExtCon
nec

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 (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
local_binds)) = do
  [Id]
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. [Id] -> TM a -> TM a
bindLocals [Id]
[IdP GhcTc]
binders (TM (GRHSs GhcTc (LHsExpr GhcTc))
 -> TM (GRHSs GhcTc (LHsExpr GhcTc)))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ do
    HsLocalBindsLR GhcTc GhcTc
local_binds' <- HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
addTickHsLocalBinds SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
local_binds
    [LGRHS GhcTc (LHsExpr GhcTc)]
guarded' <- (LGRHS GhcTc (LHsExpr GhcTc) -> TM (LGRHS GhcTc (LHsExpr GhcTc)))
-> [LGRHS GhcTc (LHsExpr GhcTc)]
-> TM [LGRHS GhcTc (LHsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))
 -> TM (SrcSpanLess (LGRHS GhcTc (LHsExpr GhcTc))))
-> LGRHS GhcTc (LHsExpr GhcTc) -> TM (LGRHS GhcTc (LHsExpr GhcTc))
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL (Bool
-> Bool
-> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS Bool
isOneOfMany Bool
isLambda)) [LGRHS GhcTc (LHsExpr GhcTc)]
guarded
    GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)))
-> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ XCGRHSs GhcTc (LHsExpr GhcTc)
-> [LGRHS GhcTc (LHsExpr GhcTc)]
-> LHsLocalBinds GhcTc
-> GRHSs GhcTc (LHsExpr GhcTc)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
x [LGRHS GhcTc (LHsExpr GhcTc)]
guarded' (SrcSpan -> SrcSpanLess (LHsLocalBinds GhcTc) -> LHsLocalBinds GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
local_binds')
  where
    binders :: [IdP GhcTc]
binders = HsLocalBindsLR GhcTc GhcTc -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass).
HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectLocalBinders SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
local_binds
addTickGRHSs Bool
_ Bool
_ (XGRHSs XXGRHSs GhcTc (LHsExpr GhcTc)
nec) = NoExtCon -> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. NoExtCon -> a
noExtCon XXGRHSs GhcTc (LHsExpr GhcTc)
NoExtCon
nec

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
  ([ExprLStmt GhcTc]
stmts',LHsExpr GhcTc
expr') <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc]
-> TM (LHsExpr GhcTc)
-> TM ([ExprLStmt GhcTc], LHsExpr GhcTc)
forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' ((Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel)
forall a. a -> Maybe a
Just ((Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel))
-> (Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel)
forall a b. (a -> b) -> a -> b
$ CondBox -> Bool -> BoxLabel
BinBox (CondBox -> Bool -> BoxLabel) -> CondBox -> Bool -> BoxLabel
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)
  GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)))
-> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcTc (LHsExpr GhcTc)
-> [ExprLStmt GhcTc] -> LHsExpr GhcTc -> GRHS GhcTc (LHsExpr GhcTc)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LHsExpr GhcTc)
x [ExprLStmt GhcTc]
stmts' LHsExpr GhcTc
expr'
addTickGRHS Bool
_ Bool
_ (XGRHS XXGRHS GhcTc (LHsExpr GhcTc)
nec) = NoExtCon -> TM (GRHS GhcTc (LHsExpr GhcTc))
forall a. NoExtCon -> a
noExtCon XXGRHS GhcTc (LHsExpr GhcTc)
NoExtCon
nec

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@(LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsExpr 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 ->
       FilePath -> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a. FilePath -> TM a -> TM a
addPathEntry FilePath
"\\" (TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc))
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc)
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-} SrcSpan
pos (TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
           HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr SrcSpanLess (LHsExpr GhcTc)
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
  ([ExprLStmt GhcTc]
stmts, ()
_) <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM () -> TM ([ExprLStmt GhcTc], ())
forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts (() -> TM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
forall (m :: * -> *) a. Monad m => a -> m a
return [ExprLStmt GhcTc]
stmts

addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
               -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' :: Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
lstmts TM a
res
  = [Id] -> TM ([ExprLStmt GhcTc], a) -> TM ([ExprLStmt GhcTc], a)
forall a. [Id] -> TM a -> TM a
bindLocals ([ExprLStmt GhcTc] -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass) body.
[LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]
collectLStmtsBinders [ExprLStmt GhcTc]
lstmts) (TM ([ExprLStmt GhcTc], a) -> TM ([ExprLStmt GhcTc], a))
-> TM ([ExprLStmt GhcTc], a) -> TM ([ExprLStmt GhcTc], a)
forall a b. (a -> b) -> a -> b
$
    do { [ExprLStmt GhcTc]
lstmts' <- (ExprLStmt GhcTc -> TM (ExprLStmt GhcTc))
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (ExprLStmt GhcTc)
 -> TM (SrcSpanLess (ExprLStmt GhcTc)))
-> ExprLStmt GhcTc -> TM (ExprLStmt GhcTc)
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m 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
       ; ([ExprLStmt GhcTc], a) -> TM ([ExprLStmt GhcTc], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ExprLStmt 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 Bool
noret SyntaxExpr GhcTc
ret) = do
        (LHsExpr GhcTc
 -> Bool -> SyntaxExpr GhcTc -> Stmt GhcTc (LHsExpr GhcTc))
-> TM (LHsExpr GhcTc)
-> TM Bool
-> TM (SyntaxExpr GhcTc)
-> TM (Stmt GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> Bool
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsExpr GhcTc)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
                (Bool -> TM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)
x LPat GhcTc
pat LHsExpr GhcTc
e SyntaxExpr GhcTc
bind SyntaxExpr GhcTc
fail) = do
        (Located (Pat GhcTc)
 -> LHsExpr GhcTc
 -> SyntaxExpr GhcTc
 -> SyntaxExpr GhcTc
 -> Stmt GhcTc (LHsExpr GhcTc))
-> TM (Located (Pat GhcTc))
-> TM (LHsExpr GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (Stmt GhcTc (LHsExpr GhcTc))
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 (XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
-> LPat GhcTc
-> LHsExpr GhcTc
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsExpr GhcTc)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
x)
                (LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS 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
fail)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
x LHsExpr GhcTc
e SyntaxExpr GhcTc
bind' SyntaxExpr GhcTc
guard') = do
        (LHsExpr GhcTc
 -> SyntaxExpr GhcTc
 -> SyntaxExpr GhcTc
 -> Stmt GhcTc (LHsExpr GhcTc))
-> TM (LHsExpr GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (Stmt GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsExpr GhcTc)
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 (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
binds)) = do
        (HsLocalBindsLR GhcTc GhcTc -> Stmt GhcTc (LHsExpr GhcTc))
-> TM (HsLocalBindsLR GhcTc GhcTc)
-> TM (Stmt GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
-> LHsLocalBinds GhcTc -> Stmt GhcTc (LHsExpr GhcTc)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
x (LHsLocalBinds GhcTc -> Stmt GhcTc (LHsExpr GhcTc))
-> (HsLocalBindsLR GhcTc GhcTc -> LHsLocalBinds GhcTc)
-> HsLocalBindsLR GhcTc GhcTc
-> Stmt GhcTc (LHsExpr GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcSpanLess (LHsLocalBinds GhcTc) -> LHsLocalBinds GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l)
                (HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
addTickHsLocalBinds SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
binds)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (ParStmt XParStmt GhcTc GhcTc (LHsExpr GhcTc)
x [ParStmtBlock GhcTc GhcTc]
pairs HsExpr GhcTc
mzipExpr SyntaxExpr GhcTc
bindExpr) = do
    ([ParStmtBlock GhcTc GhcTc]
 -> HsExpr GhcTc -> SyntaxExpr GhcTc -> Stmt GhcTc (LHsExpr GhcTc))
-> TM [ParStmtBlock GhcTc GhcTc]
-> TM (HsExpr GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (Stmt GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XParStmt GhcTc GhcTc (LHsExpr GhcTc)
-> [ParStmtBlock GhcTc GhcTc]
-> HsExpr GhcTc
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsExpr GhcTc)
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)
        ((ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc))
-> [ParStmtBlock GhcTc GhcTc] -> TM [ParStmtBlock GhcTc GhcTc]
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)
        (LHsExpr GhcTc -> HsExpr GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
hpcSrcSpan SrcSpanLess (LHsExpr GhcTc)
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
    [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args' <- ((SyntaxExpr GhcTc, ApplicativeArg GhcTc)
 -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc))
-> [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
-> TM [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
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
    Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
-> [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
-> Maybe (SyntaxExpr GhcTc)
-> Stmt GhcTc (LHsExpr GhcTc)
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 [(SyntaxExpr GhcTc, 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
    [ExprLStmt GhcTc]
t_s <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts
    Maybe (LHsExpr GhcTc)
t_y <- (LHsExpr GhcTc -> TM (LHsExpr GhcTc))
-> Maybe (LHsExpr GhcTc) -> TM (Maybe (LHsExpr GhcTc))
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
    LHsExpr GhcTc
t_u <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS LHsExpr GhcTc
using
    SyntaxExpr GhcTc
t_f <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
returnExpr
    SyntaxExpr GhcTc
t_b <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bindExpr
    HsExpr GhcTc
t_m <- (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcTc -> HsExpr GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
hpcSrcSpan SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
liftMExpr))
    Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc)))
-> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ Stmt GhcTc (LHsExpr GhcTc)
stmt { trS_stmts :: [ExprLStmt GhcTc]
trS_stmts = [ExprLStmt GhcTc]
t_s, trS_by :: Maybe (LHsExpr GhcTc)
trS_by = Maybe (LHsExpr GhcTc)
t_y, trS_using :: LHsExpr GhcTc
trS_using = LHsExpr GhcTc
t_u
                  , trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExpr GhcTc
t_f, trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExpr GhcTc
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 { [ExprLStmt GhcTc]
stmts' <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard (Stmt GhcTc (LHsExpr GhcTc) -> [ExprLStmt GhcTc]
forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; SyntaxExpr GhcTc
ret'   <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (Stmt GhcTc (LHsExpr GhcTc) -> SyntaxExpr GhcTc
forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; SyntaxExpr GhcTc
mfix'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (Stmt GhcTc (LHsExpr GhcTc) -> SyntaxExpr GhcTc
forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; SyntaxExpr GhcTc
bind'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (Stmt GhcTc (LHsExpr GhcTc) -> SyntaxExpr GhcTc
forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn Stmt GhcTc (LHsExpr GhcTc)
stmt)
       ; Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt GhcTc (LHsExpr GhcTc)
stmt { recS_stmts :: [ExprLStmt GhcTc]
recS_stmts = [ExprLStmt GhcTc]
stmts', recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExpr GhcTc
ret'
                      , recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExpr GhcTc
mfix', recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExpr GhcTc
bind' }) }

addTickStmt Maybe (Bool -> BoxLabel)
_ (XStmtLR XXStmtLR GhcTc GhcTc (LHsExpr GhcTc)
nec) = NoExtCon -> TM (Stmt GhcTc (LHsExpr GhcTc))
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcTc GhcTc (LHsExpr GhcTc)
NoExtCon
nec

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) =
  (SyntaxExpr GhcTc
 -> ApplicativeArg GhcTc
 -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc))
-> TM (SyntaxExpr GhcTc)
-> TM (ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
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
x LPat GhcTc
pat LHsExpr GhcTc
expr Bool
isBody SyntaxExpr GhcTc
fail) =
    (XApplicativeArgOne GhcTc
-> LPat GhcTc
-> LHsExpr GhcTc
-> Bool
-> SyntaxExpr GhcTc
-> ApplicativeArg GhcTc
forall idL.
XApplicativeArgOne idL
-> LPat idL
-> LHsExpr idL
-> Bool
-> SyntaxExpr idL
-> ApplicativeArg idL
ApplicativeArgOne XApplicativeArgOne GhcTc
x)
      (Located (Pat GhcTc)
 -> LHsExpr GhcTc
 -> Bool
 -> SyntaxExpr GhcTc
 -> ApplicativeArg GhcTc)
-> TM (Located (Pat GhcTc))
-> TM
     (LHsExpr GhcTc -> Bool -> SyntaxExpr GhcTc -> ApplicativeArg GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat
      TM
  (LHsExpr GhcTc -> Bool -> SyntaxExpr GhcTc -> ApplicativeArg GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (Bool -> SyntaxExpr GhcTc -> ApplicativeArg GhcTc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
expr
      TM (Bool -> SyntaxExpr GhcTc -> ApplicativeArg GhcTc)
-> TM Bool -> TM (SyntaxExpr GhcTc -> ApplicativeArg GhcTc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> TM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isBody
      TM (SyntaxExpr GhcTc -> ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc) -> TM (ApplicativeArg GhcTc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
fail
  addTickArg (ApplicativeArgMany XApplicativeArgMany GhcTc
x [ExprLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat) =
    (XApplicativeArgMany GhcTc
-> [ExprLStmt GhcTc]
-> HsExpr GhcTc
-> LPat GhcTc
-> ApplicativeArg GhcTc
forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL] -> HsExpr idL -> LPat idL -> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcTc
x)
      ([ExprLStmt GhcTc]
 -> HsExpr GhcTc -> Located (Pat GhcTc) -> ApplicativeArg GhcTc)
-> TM [ExprLStmt GhcTc]
-> TM (HsExpr GhcTc -> Located (Pat GhcTc) -> ApplicativeArg GhcTc)
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
      TM (HsExpr GhcTc -> Located (Pat GhcTc) -> ApplicativeArg GhcTc)
-> TM (HsExpr GhcTc)
-> TM (Located (Pat GhcTc) -> ApplicativeArg GhcTc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LHsExpr GhcTc -> HsExpr GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
hpcSrcSpan SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
ret))
      TM (Located (Pat GhcTc) -> ApplicativeArg GhcTc)
-> TM (Located (Pat GhcTc)) -> TM (ApplicativeArg GhcTc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat
  addTickArg (XApplicativeArg XXApplicativeArg GhcTc
nec) = NoExtCon -> TM (ApplicativeArg GhcTc)
forall a. NoExtCon -> a
noExtCon XXApplicativeArg GhcTc
NoExtCon
nec

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) =
    ([ExprLStmt GhcTc]
 -> [Id] -> SyntaxExpr GhcTc -> ParStmtBlock GhcTc GhcTc)
-> TM [ExprLStmt GhcTc]
-> TM [Id]
-> TM (SyntaxExpr GhcTc)
-> TM (ParStmtBlock GhcTc GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XParStmtBlock GhcTc GhcTc
-> [ExprLStmt GhcTc]
-> [IdP GhcTc]
-> SyntaxExpr GhcTc
-> ParStmtBlock GhcTc GhcTc
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)
        ([Id] -> TM [Id]
forall (m :: * -> *) a. Monad m => a -> m a
return [Id]
[IdP GhcTc]
ids)
        (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
returnExpr)
addTickStmtAndBinders Maybe (Bool -> BoxLabel)
_ (XParStmtBlock XXParStmtBlock GhcTc GhcTc
nec) = NoExtCon -> TM (ParStmtBlock GhcTc GhcTc)
forall a. NoExtCon -> a
noExtCon XXParStmtBlock GhcTc GhcTc
NoExtCon
nec

addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds :: HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
addTickHsLocalBinds (HsValBinds XHsValBinds GhcTc GhcTc
x HsValBindsLR GhcTc GhcTc
binds) =
        (HsValBindsLR GhcTc GhcTc -> HsLocalBindsLR GhcTc GhcTc)
-> TM (HsValBindsLR GhcTc GhcTc) -> TM (HsLocalBindsLR GhcTc GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XHsValBinds GhcTc GhcTc
-> HsValBindsLR GhcTc GhcTc -> HsLocalBindsLR GhcTc GhcTc
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcTc GhcTc
x)
                (HsValBindsLR GhcTc GhcTc -> TM (HsValBindsLR GhcTc GhcTc)
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)  =
        (HsIPBinds GhcTc -> HsLocalBindsLR GhcTc GhcTc)
-> TM (HsIPBinds GhcTc) -> TM (HsLocalBindsLR GhcTc GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XHsIPBinds GhcTc GhcTc
-> HsIPBinds GhcTc -> HsLocalBindsLR GhcTc GhcTc
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)  = HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds GhcTc GhcTc -> HsLocalBindsLR GhcTc GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
x)
addTickHsLocalBinds (XHsLocalBindsLR XXHsLocalBindsLR GhcTc GhcTc
x)  = HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XXHsLocalBindsLR GhcTc GhcTc -> HsLocalBindsLR GhcTc GhcTc
forall idL idR. XXHsLocalBindsLR idL idR -> HsLocalBindsLR idL idR
XHsLocalBindsLR XXHsLocalBindsLR GhcTc GhcTc
x)

addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
                  -> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
        NHsValBindsLR GhcTc
b <- ([(RecFlag, LHsBinds GhcTc)]
 -> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR GhcTc)
-> TM [(RecFlag, LHsBinds GhcTc)]
-> TM [LSig (GhcPass 'Renamed)]
-> TM (NHsValBindsLR GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [(RecFlag, LHsBinds GhcTc)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR GhcTc
forall idL.
[(RecFlag, LHsBinds idL)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR idL
NValBinds
                (((RecFlag, LHsBinds GhcTc) -> TM (RecFlag, LHsBinds GhcTc))
-> [(RecFlag, LHsBinds GhcTc)] -> TM [(RecFlag, LHsBinds GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (RecFlag
rec,LHsBinds GhcTc
binds') ->
                                (RecFlag -> LHsBinds GhcTc -> (RecFlag, LHsBinds GhcTc))
-> TM RecFlag
-> TM (LHsBinds GhcTc)
-> TM (RecFlag, LHsBinds GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
                                        (RecFlag -> TM RecFlag
forall (m :: * -> *) a. Monad m => a -> m a
return RecFlag
rec)
                                        (LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds LHsBinds GhcTc
binds'))
                        [(RecFlag, LHsBinds GhcTc)]
binds)
                ([LSig (GhcPass 'Renamed)] -> TM [LSig (GhcPass 'Renamed)]
forall (m :: * -> *) a. Monad m => a -> m a
return [LSig (GhcPass 'Renamed)]
sigs)
        HsValBindsLR GhcTc (GhcPass b)
-> TM (HsValBindsLR GhcTc (GhcPass b))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsValBindsLR GhcTc (GhcPass b)
 -> TM (HsValBindsLR GhcTc (GhcPass b)))
-> HsValBindsLR GhcTc (GhcPass b)
-> TM (HsValBindsLR GhcTc (GhcPass b))
forall a b. (a -> b) -> a -> b
$ XXValBindsLR GhcTc (GhcPass b) -> HsValBindsLR GhcTc (GhcPass b)
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR XXValBindsLR GhcTc (GhcPass b)
NHsValBindsLR GhcTc
b
addTickHsValBinds HsValBindsLR GhcTc (GhcPass a)
_ = FilePath -> TM (HsValBindsLR GhcTc (GhcPass b))
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) =
        (TcEvBinds -> [LIPBind GhcTc] -> HsIPBinds GhcTc)
-> TM TcEvBinds -> TM [LIPBind GhcTc] -> TM (HsIPBinds GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 TcEvBinds -> [LIPBind GhcTc] -> HsIPBinds GhcTc
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds
                (TcEvBinds -> TM TcEvBinds
forall (m :: * -> *) a. Monad m => a -> m a
return XIPBinds GhcTc
TcEvBinds
dictbinds)
                ((LIPBind GhcTc -> TM (LIPBind GhcTc))
-> [LIPBind GhcTc] -> TM [LIPBind GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LIPBind GhcTc) -> TM (SrcSpanLess (LIPBind GhcTc)))
-> LIPBind GhcTc -> TM (LIPBind GhcTc)
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL (SrcSpanLess (LIPBind GhcTc) -> TM (SrcSpanLess (LIPBind GhcTc))
IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind)) [LIPBind GhcTc]
ipbinds)
addTickHsIPBinds (XHsIPBinds XXHsIPBinds GhcTc
x) = HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XXHsIPBinds GhcTc -> HsIPBinds GhcTc
forall id. XXHsIPBinds id -> HsIPBinds id
XHsIPBinds XXHsIPBinds GhcTc
x)

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

-- 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@(SyntaxExpr { syn_expr :: forall p. SyntaxExpr p -> HsExpr p
syn_expr = HsExpr GhcTc
x }) = do
        HsExpr GhcTc
x' <- (LHsExpr GhcTc -> HsExpr GhcTc)
-> TM (LHsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcTc -> HsExpr GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
x))
        SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc))
-> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcTc
syn { syn_expr :: HsExpr GhcTc
syn_expr = HsExpr GhcTc
x' }
-- we do not walk into patterns.
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat = Located (Pat GhcTc) -> TM (Located (Pat GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return Located (Pat GhcTc)
LPat GhcTc
pat

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

addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (LHsCmd GhcTc -> Located (SrcSpanLess (LHsCmd GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
pos SrcSpanLess (LHsCmd GhcTc)
c0) = do
        HsCmd GhcTc
c1 <- HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd SrcSpanLess (LHsCmd GhcTc)
HsCmd GhcTc
c0
        LHsCmd GhcTc -> TM (LHsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcTc -> TM (LHsCmd GhcTc))
-> LHsCmd GhcTc -> TM (LHsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsCmd GhcTc) -> LHsCmd GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsCmd GhcTc)
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) =
        (MatchGroup GhcTc (LHsCmd GhcTc) -> HsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc)) -> TM (HsCmd GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XCmdLam GhcTc -> MatchGroup GhcTc (LHsCmd GhcTc) -> HsCmd GhcTc
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) =
        (LHsCmd GhcTc -> LHsExpr GhcTc -> HsCmd GhcTc)
-> TM (LHsCmd GhcTc) -> TM (LHsExpr GhcTc) -> TM (HsCmd GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XCmdApp GhcTc -> LHsCmd GhcTc -> LHsExpr GhcTc -> HsCmd GhcTc
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) = (LHsCmd GhcTc -> HsCmd GhcTc)
-> TM (LHsCmd GhcTc) -> TM (HsCmd GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XCmdPar GhcTc -> LHsCmd GhcTc -> HsCmd GhcTc
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) =
        (LHsExpr GhcTc -> MatchGroup GhcTc (LHsCmd GhcTc) -> HsCmd GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
-> TM (HsCmd GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XCmdCase GhcTc
-> LHsExpr GhcTc -> MatchGroup GhcTc (LHsCmd GhcTc) -> HsCmd GhcTc
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 (HsCmdIf XCmdIf GhcTc
x Maybe (SyntaxExpr GhcTc)
cnd LHsExpr GhcTc
e1 LHsCmd GhcTc
c2 LHsCmd GhcTc
c3) =
        (LHsExpr GhcTc -> LHsCmd GhcTc -> LHsCmd GhcTc -> HsCmd GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsCmd GhcTc)
-> TM (LHsCmd GhcTc)
-> TM (HsCmd GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XCmdIf GhcTc
-> Maybe (SyntaxExpr GhcTc)
-> LHsExpr GhcTc
-> LHsCmd GhcTc
-> LHsCmd GhcTc
-> HsCmd GhcTc
forall id.
XCmdIf id
-> Maybe (SyntaxExpr id)
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcTc
x Maybe (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 (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
binds) LHsCmd GhcTc
c) =
        [Id] -> TM (HsCmd GhcTc) -> TM (HsCmd GhcTc)
forall a. [Id] -> TM a -> TM a
bindLocals (HsLocalBindsLR GhcTc GhcTc -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass).
HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectLocalBinders SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
binds) (TM (HsCmd GhcTc) -> TM (HsCmd GhcTc))
-> TM (HsCmd GhcTc) -> TM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$
          (HsLocalBindsLR GhcTc GhcTc -> LHsCmd GhcTc -> HsCmd GhcTc)
-> TM (HsLocalBindsLR GhcTc GhcTc)
-> TM (LHsCmd GhcTc)
-> TM (HsCmd GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XCmdLet GhcTc -> LHsLocalBinds GhcTc -> LHsCmd GhcTc -> HsCmd GhcTc
forall id. XCmdLet id -> LHsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet XCmdLet GhcTc
x (LHsLocalBinds GhcTc -> LHsCmd GhcTc -> HsCmd GhcTc)
-> (HsLocalBindsLR GhcTc GhcTc -> LHsLocalBinds GhcTc)
-> HsLocalBindsLR GhcTc GhcTc
-> LHsCmd GhcTc
-> HsCmd GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcSpanLess (LHsLocalBinds GhcTc) -> LHsLocalBinds GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l)
                   (HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
addTickHsLocalBinds SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
binds) -- to think about: !patterns.
                   (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
addTickHsCmd (HsCmdDo XCmdDo GhcTc
srcloc (Located [CmdLStmt GhcTc]
-> Located (SrcSpanLess (Located [CmdLStmt GhcTc]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located [CmdLStmt GhcTc])
stmts))
  = do { ([CmdLStmt GhcTc]
stmts', ()
_) <- [CmdLStmt GhcTc] -> TM () -> TM ([CmdLStmt GhcTc], ())
forall a. [CmdLStmt GhcTc] -> TM a -> TM ([CmdLStmt GhcTc], a)
addTickLCmdStmts' [CmdLStmt GhcTc]
SrcSpanLess (Located [CmdLStmt GhcTc])
stmts (() -> TM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; HsCmd GhcTc -> TM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdDo GhcTc -> Located [CmdLStmt GhcTc] -> HsCmd GhcTc
forall id. XCmdDo id -> Located [CmdLStmt id] -> HsCmd id
HsCmdDo XCmdDo GhcTc
srcloc (SrcSpan
-> SrcSpanLess (Located [CmdLStmt GhcTc])
-> Located [CmdLStmt GhcTc]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [CmdLStmt GhcTc]
SrcSpanLess (Located [CmdLStmt GhcTc])
stmts')) }

addTickHsCmd (HsCmdArrApp  XCmdArrApp GhcTc
arr_ty LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
ty1 Bool
lr) =
        (Type
 -> LHsExpr GhcTc
 -> LHsExpr GhcTc
 -> HsArrAppType
 -> Bool
 -> HsCmd GhcTc)
-> TM Type
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM HsArrAppType
-> TM Bool
-> TM (HsCmd GhcTc)
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 Type
-> LHsExpr GhcTc
-> LHsExpr GhcTc
-> HsArrAppType
-> Bool
-> HsCmd GhcTc
forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp
               (Type -> TM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
XCmdArrApp GhcTc
arr_ty)
               (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
               (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e2)
               (HsArrAppType -> TM HsArrAppType
forall (m :: * -> *) a. Monad m => a -> m a
return HsArrAppType
ty1)
               (Bool -> TM Bool
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) =
        (LHsExpr GhcTc
 -> LexicalFixity
 -> Maybe Fixity
 -> [LHsCmdTop GhcTc]
 -> HsCmd GhcTc)
-> TM (LHsExpr GhcTc)
-> TM LexicalFixity
-> TM (Maybe Fixity)
-> TM [LHsCmdTop GhcTc]
-> TM (HsCmd GhcTc)
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 (XCmdArrForm GhcTc
-> LHsExpr GhcTc
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcTc]
-> HsCmd GhcTc
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)
               (LexicalFixity -> TM LexicalFixity
forall (m :: * -> *) a. Monad m => a -> m a
return LexicalFixity
f)
               (Maybe Fixity -> TM (Maybe Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Fixity
fix)
               ((LHsCmdTop GhcTc -> TM (LHsCmdTop GhcTc))
-> [LHsCmdTop GhcTc] -> TM [LHsCmdTop GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LHsCmdTop GhcTc)
 -> TM (SrcSpanLess (LHsCmdTop GhcTc)))
-> LHsCmdTop GhcTc -> TM (LHsCmdTop GhcTc)
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL (SrcSpanLess (LHsCmdTop GhcTc) -> TM (SrcSpanLess (LHsCmdTop GhcTc))
HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop)) [LHsCmdTop GhcTc]
cmdtop)

addTickHsCmd (HsCmdWrap XCmdWrap GhcTc
x HsWrapper
w HsCmd GhcTc
cmd)
  = (HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc)
-> TM HsWrapper -> TM (HsCmd GhcTc) -> TM (HsCmd GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XCmdWrap GhcTc -> HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc
forall id. XCmdWrap id -> HsWrapper -> HsCmd id -> HsCmd id
HsCmdWrap XCmdWrap GhcTc
x) (HsWrapper -> TM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
w) (HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd HsCmd GhcTc
cmd)

addTickHsCmd (XCmd XXCmd GhcTc
nec) = NoExtCon -> TM (HsCmd GhcTc)
forall a. NoExtCon -> a
noExtCon XXCmd GhcTc
NoExtCon
nec

-- 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 -> Located [LMatch p body]
mg_alts = (Located [LMatch GhcTc (LHsCmd GhcTc)]
-> Located (SrcSpanLess (Located [LMatch GhcTc (LHsCmd GhcTc)]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located [LMatch GhcTc (LHsCmd GhcTc)])
matches) }) = do
  [LMatch GhcTc (LHsCmd GhcTc)]
matches' <- (LMatch GhcTc (LHsCmd GhcTc) -> TM (LMatch GhcTc (LHsCmd GhcTc)))
-> [LMatch GhcTc (LHsCmd GhcTc)]
-> TM [LMatch GhcTc (LHsCmd GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LMatch GhcTc (LHsCmd GhcTc))
 -> TM (SrcSpanLess (LMatch GhcTc (LHsCmd GhcTc))))
-> LMatch GhcTc (LHsCmd GhcTc) -> TM (LMatch GhcTc (LHsCmd GhcTc))
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL SrcSpanLess (LMatch GhcTc (LHsCmd GhcTc))
-> TM (SrcSpanLess (LMatch GhcTc (LHsCmd GhcTc)))
Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch) [LMatch GhcTc (LHsCmd GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsCmd GhcTc)])
matches
  MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcTc (LHsCmd GhcTc)
 -> TM (MatchGroup GhcTc (LHsCmd GhcTc)))
-> MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcTc (LHsCmd GhcTc)
mg { mg_alts :: Located [LMatch GhcTc (LHsCmd GhcTc)]
mg_alts = SrcSpan
-> SrcSpanLess (Located [LMatch GhcTc (LHsCmd GhcTc)])
-> Located [LMatch GhcTc (LHsCmd GhcTc)]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [LMatch GhcTc (LHsCmd GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsCmd GhcTc)])
matches' }
addTickCmdMatchGroup (XMatchGroup XXMatchGroup GhcTc (LHsCmd GhcTc)
nec) = NoExtCon -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
forall a. NoExtCon -> a
noExtCon XXMatchGroup GhcTc (LHsCmd GhcTc)
NoExtCon
nec

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 }) =
  [Id]
-> TM (Match GhcTc (LHsCmd GhcTc))
-> TM (Match GhcTc (LHsCmd GhcTc))
forall a. [Id] -> TM a -> TM a
bindLocals ([LPat GhcTc] -> [IdP GhcTc]
forall (p :: Pass). [LPat (GhcPass p)] -> [IdP (GhcPass p)]
collectPatsBinders [LPat GhcTc]
pats) (TM (Match GhcTc (LHsCmd GhcTc))
 -> TM (Match GhcTc (LHsCmd GhcTc)))
-> TM (Match GhcTc (LHsCmd GhcTc))
-> TM (Match GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$ do
    GRHSs GhcTc (LHsCmd GhcTc)
gRHSs' <- GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs GRHSs GhcTc (LHsCmd GhcTc)
gRHSs
    Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)))
-> Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$ Match GhcTc (LHsCmd GhcTc)
match { m_grhss :: GRHSs GhcTc (LHsCmd GhcTc)
m_grhss = GRHSs GhcTc (LHsCmd GhcTc)
gRHSs' }
addTickCmdMatch (XMatch XXMatch GhcTc (LHsCmd GhcTc)
nec) = NoExtCon -> TM (Match GhcTc (LHsCmd GhcTc))
forall a. NoExtCon -> a
noExtCon XXMatch GhcTc (LHsCmd GhcTc)
NoExtCon
nec

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 (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
local_binds)) = do
  [Id]
-> TM (GRHSs GhcTc (LHsCmd GhcTc))
-> TM (GRHSs GhcTc (LHsCmd GhcTc))
forall a. [Id] -> TM a -> TM a
bindLocals [Id]
[IdP GhcTc]
binders (TM (GRHSs GhcTc (LHsCmd GhcTc))
 -> TM (GRHSs GhcTc (LHsCmd GhcTc)))
-> TM (GRHSs GhcTc (LHsCmd GhcTc))
-> TM (GRHSs GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$ do
    HsLocalBindsLR GhcTc GhcTc
local_binds' <- HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
addTickHsLocalBinds SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
local_binds
    [LGRHS GhcTc (LHsCmd GhcTc)]
guarded' <- (LGRHS GhcTc (LHsCmd GhcTc) -> TM (LGRHS GhcTc (LHsCmd GhcTc)))
-> [LGRHS GhcTc (LHsCmd GhcTc)] -> TM [LGRHS GhcTc (LHsCmd GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LGRHS GhcTc (LHsCmd GhcTc))
 -> TM (SrcSpanLess (LGRHS GhcTc (LHsCmd GhcTc))))
-> LGRHS GhcTc (LHsCmd GhcTc) -> TM (LGRHS GhcTc (LHsCmd GhcTc))
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL SrcSpanLess (LGRHS GhcTc (LHsCmd GhcTc))
-> TM (SrcSpanLess (LGRHS GhcTc (LHsCmd GhcTc)))
GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
addTickCmdGRHS) [LGRHS GhcTc (LHsCmd GhcTc)]
guarded
    GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)))
-> GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$ XCGRHSs GhcTc (LHsCmd GhcTc)
-> [LGRHS GhcTc (LHsCmd GhcTc)]
-> LHsLocalBinds GhcTc
-> GRHSs GhcTc (LHsCmd GhcTc)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LHsCmd GhcTc)
x [LGRHS GhcTc (LHsCmd GhcTc)]
guarded' (SrcSpan -> SrcSpanLess (LHsLocalBinds GhcTc) -> LHsLocalBinds GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
local_binds')
  where
    binders :: [IdP GhcTc]
binders = HsLocalBindsLR GhcTc GhcTc -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass).
HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectLocalBinders SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
local_binds
addTickCmdGRHSs (XGRHSs XXGRHSs GhcTc (LHsCmd GhcTc)
nec) = NoExtCon -> TM (GRHSs GhcTc (LHsCmd GhcTc))
forall a. NoExtCon -> a
noExtCon XXGRHSs GhcTc (LHsCmd GhcTc)
NoExtCon
nec

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 { ([ExprLStmt GhcTc]
stmts',LHsCmd GhcTc
expr') <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc]
-> TM (LHsCmd GhcTc)
-> TM ([ExprLStmt GhcTc], LHsCmd GhcTc)
forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' ((Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel)
forall a. a -> Maybe a
Just ((Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel))
-> (Bool -> BoxLabel) -> Maybe (Bool -> BoxLabel)
forall a b. (a -> b) -> a -> b
$ CondBox -> Bool -> BoxLabel
BinBox (CondBox -> Bool -> BoxLabel) -> CondBox -> Bool -> BoxLabel
forall a b. (a -> b) -> a -> b
$ CondBox
GuardBinBox)
                                   [ExprLStmt GhcTc]
stmts (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
cmd)
       ; GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)))
-> GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcTc (LHsCmd GhcTc)
-> [ExprLStmt GhcTc] -> LHsCmd GhcTc -> GRHS GhcTc (LHsCmd GhcTc)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LHsCmd GhcTc)
x [ExprLStmt GhcTc]
stmts' LHsCmd GhcTc
expr' }
addTickCmdGRHS (XGRHS XXGRHS GhcTc (LHsCmd GhcTc)
nec) = NoExtCon -> TM (GRHS GhcTc (LHsCmd GhcTc))
forall a. NoExtCon -> a
noExtCon XXGRHS GhcTc (LHsCmd GhcTc)
NoExtCon
nec

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

addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
addTickLCmdStmts' :: [CmdLStmt GhcTc] -> TM a -> TM ([CmdLStmt GhcTc], a)
addTickLCmdStmts' [CmdLStmt GhcTc]
lstmts TM a
res
  = [Id] -> TM ([CmdLStmt GhcTc], a) -> TM ([CmdLStmt GhcTc], a)
forall a. [Id] -> TM a -> TM a
bindLocals [Id]
[IdP GhcTc]
binders (TM ([CmdLStmt GhcTc], a) -> TM ([CmdLStmt GhcTc], a))
-> TM ([CmdLStmt GhcTc], a) -> TM ([CmdLStmt GhcTc], a)
forall a b. (a -> b) -> a -> b
$ do
        [CmdLStmt GhcTc]
lstmts' <- (CmdLStmt GhcTc -> TM (CmdLStmt GhcTc))
-> [CmdLStmt GhcTc] -> TM [CmdLStmt GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (CmdLStmt GhcTc) -> TM (SrcSpanLess (CmdLStmt GhcTc)))
-> CmdLStmt GhcTc -> TM (CmdLStmt GhcTc)
forall a b (m :: * -> *).
(HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL SrcSpanLess (CmdLStmt GhcTc) -> TM (SrcSpanLess (CmdLStmt GhcTc))
Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
addTickCmdStmt) [CmdLStmt GhcTc]
lstmts
        a
a <- TM a
res
        ([CmdLStmt GhcTc], a) -> TM ([CmdLStmt GhcTc], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmdLStmt GhcTc]
lstmts', a
a)
  where
        binders :: [IdP GhcTc]
binders = [CmdLStmt GhcTc] -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass) body.
[LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]
collectLStmtsBinders [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 SyntaxExpr GhcTc
bind SyntaxExpr GhcTc
fail) = do
        (Located (Pat GhcTc)
 -> LHsCmd GhcTc
 -> SyntaxExpr GhcTc
 -> SyntaxExpr GhcTc
 -> Stmt GhcTc (LHsCmd GhcTc))
-> TM (Located (Pat GhcTc))
-> TM (LHsCmd GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (Stmt GhcTc (LHsCmd GhcTc))
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 (XBindStmt GhcTc GhcTc (LHsCmd GhcTc)
-> LPat GhcTc
-> LHsCmd GhcTc
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsCmd GhcTc)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> 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)
                (SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return SyntaxExpr GhcTc
bind)
                (SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return SyntaxExpr GhcTc
fail)
addTickCmdStmt (LastStmt XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
x LHsCmd GhcTc
c Bool
noret SyntaxExpr GhcTc
ret) = do
        (LHsCmd GhcTc
 -> Bool -> SyntaxExpr GhcTc -> Stmt GhcTc (LHsCmd GhcTc))
-> TM (LHsCmd GhcTc)
-> TM Bool
-> TM (SyntaxExpr GhcTc)
-> TM (Stmt GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
-> LHsCmd GhcTc
-> Bool
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsCmd GhcTc)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
x)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
                (Bool -> TM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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') = do
        (LHsCmd GhcTc
 -> SyntaxExpr GhcTc
 -> SyntaxExpr GhcTc
 -> Stmt GhcTc (LHsCmd GhcTc))
-> TM (LHsCmd GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (SyntaxExpr GhcTc)
-> TM (Stmt GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (XBodyStmt GhcTc GhcTc (LHsCmd GhcTc)
-> LHsCmd GhcTc
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsCmd GhcTc)
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 (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsLocalBinds GhcTc)
binds)) = do
        (HsLocalBindsLR GhcTc GhcTc -> Stmt GhcTc (LHsCmd GhcTc))
-> TM (HsLocalBindsLR GhcTc GhcTc)
-> TM (Stmt GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XLetStmt GhcTc GhcTc (LHsCmd GhcTc)
-> LHsLocalBinds GhcTc -> Stmt GhcTc (LHsCmd GhcTc)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcTc GhcTc (LHsCmd GhcTc)
x (LHsLocalBinds GhcTc -> Stmt GhcTc (LHsCmd GhcTc))
-> (HsLocalBindsLR GhcTc GhcTc -> LHsLocalBinds GhcTc)
-> HsLocalBindsLR GhcTc GhcTc
-> Stmt GhcTc (LHsCmd GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcSpanLess (LHsLocalBinds GhcTc) -> LHsLocalBinds GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l)
                (HsLocalBindsLR GhcTc GhcTc -> TM (HsLocalBindsLR GhcTc GhcTc)
addTickHsLocalBinds SrcSpanLess (LHsLocalBinds GhcTc)
HsLocalBindsLR GhcTc GhcTc
binds)
addTickCmdStmt stmt :: Stmt GhcTc (LHsCmd GhcTc)
stmt@(RecStmt {})
  = do { [CmdLStmt GhcTc]
stmts' <- [CmdLStmt GhcTc] -> TM [CmdLStmt GhcTc]
addTickLCmdStmts (Stmt GhcTc (LHsCmd GhcTc) -> [CmdLStmt GhcTc]
forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; SyntaxExpr GhcTc
ret'   <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (Stmt GhcTc (LHsCmd GhcTc) -> SyntaxExpr GhcTc
forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; SyntaxExpr GhcTc
mfix'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (Stmt GhcTc (LHsCmd GhcTc) -> SyntaxExpr GhcTc
forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; SyntaxExpr GhcTc
bind'  <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (Stmt GhcTc (LHsCmd GhcTc) -> SyntaxExpr GhcTc
forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn Stmt GhcTc (LHsCmd GhcTc)
stmt)
       ; Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt GhcTc (LHsCmd GhcTc)
stmt { recS_stmts :: [CmdLStmt GhcTc]
recS_stmts = [CmdLStmt GhcTc]
stmts', recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExpr GhcTc
ret'
                      , recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExpr GhcTc
mfix', recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExpr GhcTc
bind' }) }
addTickCmdStmt ApplicativeStmt{} =
  FilePath -> TM (Stmt GhcTc (LHsCmd GhcTc))
forall a. FilePath -> a
panic FilePath
"ToDo: addTickCmdStmt ApplicativeLastStmt"
addTickCmdStmt (XStmtLR XXStmtLR GhcTc GhcTc (LHsCmd GhcTc)
nec) =
  NoExtCon -> TM (Stmt GhcTc (LHsCmd GhcTc))
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcTc GhcTc (LHsCmd GhcTc)
NoExtCon
nec

-- Others should never happen in a command context.
addTickCmdStmt Stmt GhcTc (LHsCmd GhcTc)
stmt  = FilePath -> SDoc -> TM (Stmt GhcTc (LHsCmd GhcTc))
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"addTickHsCmd" (Stmt GhcTc (LHsCmd GhcTc) -> SDoc
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  { [LHsRecField GhcTc (LHsExpr GhcTc)]
fields' <- (LHsRecField GhcTc (LHsExpr GhcTc)
 -> TM (LHsRecField GhcTc (LHsExpr GhcTc)))
-> [LHsRecField GhcTc (LHsExpr GhcTc)]
-> TM [LHsRecField GhcTc (LHsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcTc (LHsExpr GhcTc)
-> TM (LHsRecField GhcTc (LHsExpr GhcTc))
forall id.
LHsRecField' id (LHsExpr GhcTc)
-> TM (LHsRecField' id (LHsExpr GhcTc))
addTickHsRecField [LHsRecField GhcTc (LHsExpr GhcTc)]
fields
        ; HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTc (LHsExpr GhcTc)]
-> Maybe (Located Int) -> HsRecordBinds GhcTc
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [LHsRecField GhcTc (LHsExpr GhcTc)]
fields' Maybe (Located Int)
dd) }

addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
                  -> TM (LHsRecField' id (LHsExpr GhcTc))
addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
-> TM (LHsRecField' id (LHsExpr GhcTc))
addTickHsRecField (LHsRecField' id (LHsExpr GhcTc)
-> Located (SrcSpanLess (LHsRecField' id (LHsExpr GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsRecField id expr pun))
        = do { LHsExpr GhcTc
expr' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
expr
             ; LHsRecField' id (LHsExpr GhcTc)
-> TM (LHsRecField' id (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> SrcSpanLess (LHsRecField' id (LHsExpr GhcTc))
-> LHsRecField' id (LHsExpr GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (Located id
-> LHsExpr GhcTc -> Bool -> HsRecField' id (LHsExpr GhcTc)
forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField Located id
id LHsExpr GhcTc
expr' Bool
pun)) }


addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo (From LHsExpr GhcTc
e1) =
        (LHsExpr GhcTc -> ArithSeqInfo GhcTc)
-> TM (LHsExpr GhcTc) -> TM (ArithSeqInfo GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> ArithSeqInfo id
From
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e1)
addTickArithSeqInfo (FromThen LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
        (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (ArithSeqInfo GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
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) =
        (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (ArithSeqInfo GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
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) =
        (LHsExpr GhcTc
 -> LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (LHsExpr GhcTc)
-> TM (ArithSeqInfo GhcTc)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 LHsExpr GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
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
                         }

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 -> Map SrcSpan ()
blackList    :: Map SrcSpan ()
                        , TickTransEnv -> Module
this_mod     :: Module
                        , TickTransEnv -> TickishType
tickishType  :: TickishType
                        }

--      deriving Show

data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
                 deriving (TickishType -> TickishType -> Bool
(TickishType -> TickishType -> Bool)
-> (TickishType -> TickishType -> Bool) -> Eq TickishType
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 =
    Bool -> TickishType -> [TickishType] -> [TickishType]
forall a. Bool -> a -> [a] -> [a]
ifa (DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted) TickishType
Breakpoints ([TickishType] -> [TickishType]) -> [TickishType] -> [TickishType]
forall a b. (a -> b) -> a -> b
$
    Bool -> TickishType -> [TickishType] -> [TickishType]
forall a. Bool -> a -> [a] -> [a]
ifa (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc DynFlags
dflags)                TickishType
HpcTicks ([TickishType] -> [TickishType]) -> [TickishType] -> [TickishType]
forall a b. (a -> b) -> a -> b
$
    Bool -> TickishType -> [TickishType] -> [TickishType]
forall a. Bool -> a -> [a] -> [a]
ifa (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags Bool -> Bool -> Bool
&&
         DynFlags -> ProfAuto
profAuto DynFlags
dflags ProfAuto -> ProfAuto -> Bool
forall a. Eq a => a -> a -> Bool
/= ProfAuto
NoProfAuto)      TickishType
ProfNotes ([TickishType] -> [TickishType]) -> [TickishType] -> [TickishType]
forall a b. (a -> b) -> a -> b
$
    Bool -> TickishType -> [TickishType] -> [TickishType]
forall a. Bool -> a -> [a] -> [a]
ifa (DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)              TickishType
SourceNotes []
  where ifa :: Bool -> a -> [a] -> [a]
ifa Bool
f a
x [a]
xs | Bool
f         = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs
                   | Bool
otherwise = [a]
xs

-- | 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 = FreeVars
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 { TM a
-> TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
    deriving (a -> TM b -> TM a
(a -> b) -> TM a -> TM b
(forall a b. (a -> b) -> TM a -> TM b)
-> (forall a b. a -> TM b -> TM a) -> Functor TM
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
<$ :: a -> TM b -> TM a
$c<$ :: forall a b. a -> TM b -> TM a
fmap :: (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 :: a -> TM a
pure a
a = (TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
 -> TM a)
-> (TickTransEnv
    -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
_env TickTransState
st -> (a
a,FreeVars
noFVs,TickTransState
st)
    <*> :: TM (a -> b) -> TM a -> TM 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) >>= :: TM a -> (a -> TM b) -> TM b
>>= a -> TM b
k = (TickTransEnv -> TickTransState -> (b, FreeVars, TickTransState))
-> TM b
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv -> TickTransState -> (b, FreeVars, TickTransState))
 -> TM b)
-> (TickTransEnv
    -> TickTransState -> (b, FreeVars, TickTransState))
-> TM b
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 TM b
-> TickTransEnv -> TickTransState -> (b, FreeVars, TickTransState)
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 FreeVars -> FreeVars -> FreeVars
forall a. OccEnv a -> OccEnv a -> OccEnv a
`plusOccEnv` FreeVars
fv2, TickTransState
st2)

instance HasDynFlags TM where
  getDynFlags :: TM DynFlags
getDynFlags = (TickTransEnv
 -> TickTransState -> (DynFlags, FreeVars, TickTransState))
-> TM DynFlags
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv
  -> TickTransState -> (DynFlags, FreeVars, TickTransState))
 -> TM DynFlags)
-> (TickTransEnv
    -> TickTransState -> (DynFlags, FreeVars, TickTransState))
-> TM DynFlags
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 = (TickTransEnv
 -> TickTransState -> (CostCentreIndex, FreeVars, TickTransState))
-> TM CostCentreIndex
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv
  -> TickTransState -> (CostCentreIndex, FreeVars, TickTransState))
 -> TM CostCentreIndex)
-> (TickTransEnv
    -> TickTransState -> (CostCentreIndex, FreeVars, TickTransState))
-> TM CostCentreIndex
forall a b. (a -> b) -> a -> b
$ \TickTransEnv
_ TickTransState
st -> let (CostCentreIndex
idx, CostCentreState
is') = FastString -> CostCentreState -> (CostCentreIndex, CostCentreState)
getCCIndex FastString
n (CostCentreState -> (CostCentreIndex, CostCentreState))
-> CostCentreState -> (CostCentreIndex, CostCentreState)
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 = (TickTransEnv
 -> TickTransState -> (TickTransState, FreeVars, TickTransState))
-> TM TickTransState
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv
  -> TickTransState -> (TickTransState, FreeVars, TickTransState))
 -> TM TickTransState)
-> (TickTransEnv
    -> TickTransState -> (TickTransState, FreeVars, TickTransState))
-> TM TickTransState
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 = (TickTransEnv -> TickTransState -> ((), FreeVars, TickTransState))
-> TM ()
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv -> TickTransState -> ((), FreeVars, TickTransState))
 -> TM ())
-> (TickTransEnv
    -> TickTransState -> ((), FreeVars, TickTransState))
-> 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 = (TickTransEnv
 -> TickTransState -> (TickTransEnv, FreeVars, TickTransState))
-> TM TickTransEnv
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv
  -> TickTransState -> (TickTransEnv, FreeVars, TickTransState))
 -> TM TickTransEnv)
-> (TickTransEnv
    -> TickTransState -> (TickTransEnv, FreeVars, TickTransState))
-> TM TickTransEnv
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 :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
f (TM TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m) = (TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
 -> TM a)
-> (TickTransEnv
    -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
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 = (TickTransEnv
 -> TickTransState -> (TickDensity, FreeVars, TickTransState))
-> TM TickDensity
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv
  -> TickTransState -> (TickDensity, FreeVars, TickTransState))
 -> TM TickDensity)
-> (TickTransEnv
    -> TickTransState -> (TickDensity, FreeVars, TickTransState))
-> TM TickDensity
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 :: 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 TickDensity -> TickDensity -> Bool
forall a. Eq a => a -> a -> Bool
== TickDensity
d0 then TM a
th else TM a
el

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

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

getPathEntry :: TM [String]
getPathEntry :: TM [FilePath]
getPathEntry = TickTransEnv -> [FilePath]
declPath (TickTransEnv -> [FilePath]) -> TM TickTransEnv -> TM [FilePath]
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 (TickTransEnv -> FastString) -> TM TickTransEnv -> TM FastString
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
_) = SrcSpan -> SrcLoc
srcSpanStart SrcSpan
pos SrcLoc -> SrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
pos
isGoodSrcSpan' (UnhelpfulSpan FastString
_) = 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 (TickTransEnv -> TickishType) -> TM TickTransEnv -> TM 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      = FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
file_name Maybe FastString -> Maybe FastString -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> Maybe FastString
srcSpanFileName_maybe SrcSpan
pos
  Bool -> TM Bool
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 :: 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 :: [Id] -> TM a -> TM a
bindLocals [Id]
new_ids (TM TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
m)
  = (TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
 -> TM a)
-> (TickTransEnv
    -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
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 -> [Id] -> VarSet
`extendVarSetList` [Id]
new_ids } TickTransState
st of
                   (a
r, FreeVars
fv, TickTransState
st') -> (a
r, FreeVars
fv FreeVars -> [OccName] -> FreeVars
forall a. OccEnv a -> [OccName] -> OccEnv a
`delListFromOccEnv` [OccName]
occs, TickTransState
st')
  where occs :: [OccName]
occs = [ Name -> OccName
nameOccName (Id -> Name
idName Id
id) | Id
id <- [Id]
new_ids ]

isBlackListed :: SrcSpan -> TM Bool
isBlackListed :: SrcSpan -> TM Bool
isBlackListed SrcSpan
pos = (TickTransEnv
 -> TickTransState -> (Bool, FreeVars, TickTransState))
-> TM Bool
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv
  -> TickTransState -> (Bool, FreeVars, TickTransState))
 -> TM Bool)
-> (TickTransEnv
    -> TickTransState -> (Bool, FreeVars, TickTransState))
-> TM Bool
forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st ->
              case SrcSpan -> Map SrcSpan () -> Maybe ()
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SrcSpan
pos (TickTransEnv -> Map SrcSpan ()
blackList TickTransEnv
env) of
                Maybe ()
Nothing -> (Bool
False,FreeVars
noFVs,TickTransState
st)
                Just () -> (Bool
True,FreeVars
noFVs,TickTransState
st)

-- 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 =
  SrcSpan
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall a. SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan SrcSpan
pos (do
    (FreeVars
fvs, HsExpr GhcTc
e) <- TM (HsExpr GhcTc) -> TM (FreeVars, HsExpr GhcTc)
forall a. TM a -> TM (FreeVars, a)
getFreeVars TM (HsExpr GhcTc)
m
    TickTransEnv
env <- TM TickTransEnv
getEnv
    Tickish Id
tickish <- BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> FreeVars
-> [FilePath]
-> TM (Tickish Id)
mkTickish BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos FreeVars
fvs (TickTransEnv -> [FilePath]
declPath TickTransEnv
env)
    LHsExpr GhcTc -> TM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos (XTick GhcTc -> Tickish (IdP GhcTc) -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XTick p -> Tickish (IdP p) -> LHsExpr p -> HsExpr p
HsTick XTick GhcTc
NoExtField
noExtField Tickish Id
Tickish (IdP GhcTc)
tickish (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e)))
  ) (do
    HsExpr GhcTc
e <- TM (HsExpr GhcTc)
m
    LHsExpr GhcTc -> TM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos SrcSpanLess (LHsExpr GhcTc)
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 (Tickish Id))
allocATickBox :: BoxLabel
-> Bool -> Bool -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
allocATickBox BoxLabel
boxLabel Bool
countEntries Bool
topOnly  SrcSpan
pos FreeVars
fvs =
  SrcSpan
-> TM (Maybe (Tickish Id))
-> TM (Maybe (Tickish Id))
-> TM (Maybe (Tickish Id))
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
_ -> FilePath -> [FilePath]
forall a. FilePath -> a
panic FilePath
"allocATickBox"
    Tickish Id
tickish <- BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> FreeVars
-> [FilePath]
-> TM (Tickish Id)
mkTickish BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos FreeVars
fvs [FilePath]
mydecl_path
    Maybe (Tickish Id) -> TM (Maybe (Tickish Id))
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Id -> Maybe (Tickish Id)
forall a. a -> Maybe a
Just Tickish Id
tickish)
  ) (Maybe (Tickish Id) -> TM (Maybe (Tickish Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tickish Id)
forall a. Maybe a
Nothing)


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

  let ids :: [Id]
ids = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ FreeVars -> [Id]
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 fliters 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, (Id -> OccName) -> [Id] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> OccName
nameOccName(Name -> OccName) -> (Id -> Name) -> Id -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Id -> Name
idName) [Id]
ids, BoxLabel
boxLabel)

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

  DynFlags
dflags <- TM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  TickTransEnv
env <- TM TickTransEnv
getEnv
  case TickTransEnv -> TickishType
tickishType TickTransEnv
env of
    TickishType
HpcTicks -> do
      Int
c <- (TickTransState -> Int) -> TM TickTransState -> TM Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TickTransState -> Int
tickBoxCount TM TickTransState
getState
      (TickTransState -> TickTransState) -> TM ()
setState ((TickTransState -> TickTransState) -> TM ())
-> (TickTransState -> TickTransState) -> TM ()
forall a b. (a -> b) -> a -> b
$ \TickTransState
st -> TickTransState
st { tickBoxCount :: Int
tickBoxCount = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                           , mixEntries :: [MixEntry_]
mixEntries = MixEntry_
me MixEntry_ -> [MixEntry_] -> [MixEntry_]
forall a. a -> [a] -> [a]
: TickTransState -> [MixEntry_]
mixEntries TickTransState
st }
      Tickish Id -> TM (Tickish Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Id -> TM (Tickish Id)) -> Tickish Id -> TM (Tickish Id)
forall a b. (a -> b) -> a -> b
$ Module -> Int -> Tickish Id
forall id. Module -> Int -> Tickish id
HpcTick (TickTransEnv -> Module
this_mod TickTransEnv
env) Int
c

    TickishType
ProfNotes -> do
      let nm :: FastString
nm = FilePath -> FastString
mkFastString FilePath
cc_name
      CCFlavour
flavour <- CostCentreIndex -> CCFlavour
HpcCC (CostCentreIndex -> CCFlavour)
-> TM CostCentreIndex -> TM CCFlavour
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
      Tickish Id -> TM (Tickish Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Id -> TM (Tickish Id)) -> Tickish Id -> TM (Tickish Id)
forall a b. (a -> b) -> a -> b
$ CostCentre -> Bool -> Bool -> Tickish Id
forall id. CostCentre -> Bool -> Bool -> Tickish id
ProfNote CostCentre
cc Bool
count Bool
True{-scopes-}

    TickishType
Breakpoints -> do
      Int
c <- (TickTransState -> Int) -> TM TickTransState -> TM Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TickTransState -> Int
tickBoxCount TM TickTransState
getState
      (TickTransState -> TickTransState) -> TM ()
setState ((TickTransState -> TickTransState) -> TM ())
-> (TickTransState -> TickTransState) -> TM ()
forall a b. (a -> b) -> a -> b
$ \TickTransState
st -> TickTransState
st { tickBoxCount :: Int
tickBoxCount = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                           , mixEntries :: [MixEntry_]
mixEntries = MixEntry_
meMixEntry_ -> [MixEntry_] -> [MixEntry_]
forall a. a -> [a] -> [a]
:TickTransState -> [MixEntry_]
mixEntries TickTransState
st }
      Tickish Id -> TM (Tickish Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Id -> TM (Tickish Id)) -> Tickish Id -> TM (Tickish Id)
forall a b. (a -> b) -> a -> b
$ Int -> [Id] -> Tickish Id
forall id. Int -> [id] -> Tickish id
Breakpoint Int
c [Id]
ids

    TickishType
SourceNotes | RealSrcSpan RealSrcSpan
pos' <- SrcSpan
pos ->
      Tickish Id -> TM (Tickish Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Id -> TM (Tickish Id)) -> Tickish Id -> TM (Tickish Id)
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FilePath -> Tickish Id
forall id. RealSrcSpan -> FilePath -> Tickish id
SourceNote RealSrcSpan
pos' FilePath
cc_name

    TickishType
_otherwise -> FilePath -> TM (Tickish Id)
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 LHsExpr GhcTc
e <- (HsExpr GhcTc -> LHsExpr GhcTc)
-> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos) TM (HsExpr GhcTc)
m
                   SrcSpan
-> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc) -> TM (LHsExpr GhcTc)
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 LHsExpr GhcTc
e)
                     (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr 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 =
 (TickTransEnv
 -> TickTransState -> (LHsExpr GhcTc, FreeVars, TickTransState))
-> TM (LHsExpr GhcTc)
forall a.
(TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState))
-> TM a
TM ((TickTransEnv
  -> TickTransState -> (LHsExpr GhcTc, FreeVars, TickTransState))
 -> TM (LHsExpr GhcTc))
-> (TickTransEnv
    -> TickTransState -> (LHsExpr GhcTc, FreeVars, TickTransState))
-> TM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ TickTransEnv
env TickTransState
st ->
  let meT :: MixEntry_
meT = (SrcSpan
pos,TickTransEnv -> [FilePath]
declPath TickTransEnv
env, [],Bool -> BoxLabel
boxLabel Bool
True)
      meF :: MixEntry_
meF = (SrcSpan
pos,TickTransEnv -> [FilePath]
declPath TickTransEnv
env, [],Bool -> BoxLabel
boxLabel Bool
False)
      meE :: MixEntry_
meE = (SrcSpan
pos,TickTransEnv -> [FilePath]
declPath TickTransEnv
env, [],Bool -> BoxLabel
ExpBox Bool
False)
      c :: Int
c = TickTransState -> Int
tickBoxCount TickTransState
st
      mes :: [MixEntry_]
mes = TickTransState -> [MixEntry_]
mixEntries TickTransState
st
  in
     ( SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XTick GhcTc -> Tickish (IdP GhcTc) -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XTick p -> Tickish (IdP p) -> LHsExpr p -> HsExpr p
HsTick XTick GhcTc
NoExtField
noExtField (Module -> Int -> Tickish Id
forall id. Module -> Int -> Tickish id
HpcTick (TickTransEnv -> Module
this_mod TickTransEnv
env) Int
c)
          (LHsExpr GhcTc -> HsExpr GhcTc) -> LHsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
pos (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XBinTick GhcTc -> Int -> Int -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XBinTick p -> Int -> Int -> LHsExpr p -> HsExpr p
HsBinTick XBinTick GhcTc
NoExtField
noExtField (Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) LHsExpr GhcTc
e
   -- notice that F and T are reversed,
   -- because we are building the list in
   -- reverse...
     , FreeVars
noFVs
     , TickTransState
st {tickBoxCount :: Int
tickBoxCount=Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3 , mixEntries :: [MixEntry_]
mixEntries=MixEntry_
meFMixEntry_ -> [MixEntry_] -> [MixEntry_]
forall a. a -> [a] -> [a]
:MixEntry_
meTMixEntry_ -> [MixEntry_] -> [MixEntry_]
forall a. a -> [a] -> [a]
:MixEntry_
meEMixEntry_ -> [MixEntry_] -> [MixEntry_]
forall a. a -> [a] -> [a]
:[MixEntry_]
mes}
     )

mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos :: SrcSpan
pos@(RealSrcSpan RealSrcSpan
s)
   | 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 Int -> Int -> Int
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
_ = FilePath -> HpcPos
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 :: [LMatch GhcTc body] -> Bool
matchesOneOfMany [LMatch GhcTc body]
lmatches = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((LMatch GhcTc body -> Int) -> [LMatch GhcTc body] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LMatch GhcTc body -> Int
forall a p body.
(HasSrcSpan a, XXGRHSs p body ~ NoExtCon,
 SrcSpanLess a ~ Match p body, XXMatch p body ~ NoExtCon) =>
a -> Int
matchCount [LMatch GhcTc body]
lmatches) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
  where
        matchCount :: a -> Int
matchCount (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Match { m_grhss = GRHSs _ grhss _ }))
          = [LGRHS p body] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LGRHS p body]
grhss
        matchCount (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Match { m_grhss = XGRHSs nec }))
          = NoExtCon -> Int
forall a. NoExtCon -> a
noExtCon XXGRHSs p body
NoExtCon
nec
        matchCount (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XMatch nec)) = NoExtCon -> Int
forall a. NoExtCon -> a
noExtCon XXMatch p body
NoExtCon
nec
        matchCount a
_ = FilePath -> Int
forall a. FilePath -> a
panic FilePath
"matchCount: Impossible Match" -- due to #15884

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 = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Int32
hashString
        (Mix -> FilePath
forall a. Show a => a -> FilePath
show (Mix -> FilePath) -> Mix -> FilePath
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 :: Module -> HpcInfo -> SDoc
hpcInitCode :: Module -> HpcInfo -> SDoc
hpcInitCode Module
_ (NoHpcInfo {}) = SDoc
Outputable.empty
hpcInitCode Module
this_mod (HpcInfo Int
tickCount Int
hashNo)
 = [SDoc] -> SDoc
vcat
    [ FilePath -> SDoc
text FilePath
"static void hpc_init_" SDoc -> SDoc -> SDoc
<> Module -> 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
<> Module -> 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
    tickboxes :: SDoc
tickboxes = CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> CLabel
mkHpcTicksLabel (Module -> CLabel) -> Module -> CLabel
forall a b. (a -> b) -> a -> b
$ Module
this_mod)

    module_name :: SDoc
module_name  = [SDoc] -> SDoc
hcat ((Word8 -> SDoc) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
text(FilePath -> SDoc) -> (Word8 -> FilePath) -> Word8 -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) ([Word8] -> [SDoc]) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$
                         FastString -> ByteString
bytesFS (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
Module.moduleName Module
this_mod)))
    package_name :: SDoc
package_name = [SDoc] -> SDoc
hcat ((Word8 -> SDoc) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
text(FilePath -> SDoc) -> (Word8 -> FilePath) -> Word8 -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) ([Word8] -> [SDoc]) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$
                         FastString -> ByteString
bytesFS (UnitId -> FastString
unitIdFS  (Module -> UnitId
moduleUnitId Module
this_mod)))
    full_name_str :: SDoc
full_name_str
       | Module -> UnitId
moduleUnitId Module
this_mod UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
mainUnitId
       = SDoc
module_name
       | Bool
otherwise
       = SDoc
package_name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'/' SDoc -> SDoc -> SDoc
<> SDoc
module_name