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

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

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

module GHC.HsToCore.Ticks
  ( TicksConfig (..)
  , Tick (..)
  , TickishType (..)
  , addTicksToBinds
  , isGoodSrcSpan'
  , stripTicksTopHsExpr
  ) where

import GHC.Prelude as Prelude

import GHC.Hs
import GHC.Unit

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

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

import GHC.Driver.Flags (DumpFlag(..))

import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Name.Set hiding (FreeVars)
import GHC.Types.Name
import GHC.Types.CostCentre
import GHC.Types.CostCentre.State
import GHC.Types.Tickish
import GHC.Types.ProfAuto

import Control.Monad
import Data.List (isSuffixOf, intersperse)

import Trace.Hpc.Mix

import Data.Bifunctor (second)
import Data.Set (Set)
import qualified Data.Set as Set

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

-- | Configuration for compilation pass to add tick for instrumentation
-- to binding sites.
data TicksConfig = TicksConfig
  { TicksConfig -> [TickishType]
ticks_passes       :: ![TickishType]
  -- ^ What purposes do we need ticks for

  , TicksConfig -> ProfAuto
ticks_profAuto     :: !ProfAuto
  -- ^ What kind of {-# SCC #-} to add automatically

  , TicksConfig -> Bool
ticks_countEntries :: !Bool
  -- ^ Whether to count the entries to functions
  --
  -- Requires extra synchronization which can vastly degrade
  -- performance.
  }

data Tick = Tick
  { Tick -> SrcSpan
tick_loc   :: SrcSpan   -- ^ Tick source span
  , Tick -> [String]
tick_path  :: [String]  -- ^ Path to the declaration
  , Tick -> [OccName]
tick_ids   :: [OccName] -- ^ Identifiers being bound
  , Tick -> BoxLabel
tick_label :: BoxLabel  -- ^ Label for the tick counter
  }


addTicksToBinds
        :: Logger
        -> TicksConfig
        -> Module
        -> ModLocation          -- ^ location of 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 constructors in this module
        -> LHsBinds GhcTc
        -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))

addTicksToBinds :: Logger
-> TicksConfig
-> Module
-> ModLocation
-> NameSet
-> [TyCon]
-> LHsBinds GhcTc
-> IO (LHsBinds GhcTc, Maybe (String, SizedSeq Tick))
addTicksToBinds Logger
logger TicksConfig
cfg
                Module
mod ModLocation
mod_loc NameSet
exports [TyCon]
tyCons LHsBinds GhcTc
binds
  | let passes :: [TickishType]
passes = TicksConfig -> [TickishType]
ticks_passes TicksConfig
cfg
  , Bool -> Bool
not ([TickishType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TickishType]
passes)
  , Just String
orig_file <- ModLocation -> Maybe String
ml_hs_file ModLocation
mod_loc = do

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

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

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

          extendedMixEntries :: SizedSeq Tick
extendedMixEntries = TickTransState -> SizedSeq Tick
ticks TickTransState
st

     Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_ticked String
"HPC" DumpFormat
FormatHaskell
       (LHsBinds GhcTc -> SDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1)

     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 Maybe (String, SizedSeq Tick))
-> IO
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      Maybe (String, SizedSeq Tick))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, (String, SizedSeq Tick) -> Maybe (String, SizedSeq Tick)
forall a. a -> Maybe a
Just (String
orig_file2, SizedSeq Tick
extendedMixEntries))

  | Bool
otherwise = (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 Maybe (String, SizedSeq Tick))
-> IO
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      Maybe (String, SizedSeq Tick))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, Maybe (String, SizedSeq Tick)
forall a. Maybe a
Nothing)

guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile :: LHsBinds GhcTc -> String -> String
guessSourceFile LHsBinds GhcTc
binds String
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
$ (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
 -> [Maybe FastString] -> [Maybe FastString])
-> [Maybe FastString]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [Maybe FastString]
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (L SrcSpanAnnA
pos HsBindLR GhcTc GhcTc
_) [Maybe FastString]
rest ->
                               SrcSpan -> Maybe FastString
srcSpanFileName_maybe (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
pos) Maybe FastString -> [Maybe FastString] -> [Maybe FastString]
forall a. a -> [a] -> [a]
: [Maybe FastString]
rest) [] LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds
     in
     case [FastString]
top_pos of
        (FastString
file_name:[FastString]
_) | String
".hsc" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FastString -> String
unpackFS FastString
file_name
                      -> FastString -> String
unpackFS FastString
file_name
        [FastString]
_ -> String
orig_file


-- -----------------------------------------------------------------------------
-- 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
$c== :: TickDensity -> TickDensity -> Bool
== :: TickDensity -> TickDensity -> Bool
$c/= :: TickDensity -> TickDensity -> Bool
/= :: TickDensity -> TickDensity -> Bool
Eq

mkDensity :: TickishType -> ProfAuto -> TickDensity
mkDensity :: TickishType -> ProfAuto -> TickDensity
mkDensity TickishType
tickish ProfAuto
pa = case TickishType
tickish of
  TickishType
HpcTicks             -> TickDensity
TickForCoverage
  TickishType
SourceNotes          -> TickDensity
TickForCoverage
  TickishType
Breakpoints          -> TickDensity
TickForBreakPoints
  TickishType
ProfNotes ->
    case ProfAuto
pa of
      ProfAuto
ProfAutoAll      -> TickDensity
TickAllFunctions
      ProfAuto
ProfAutoTop      -> TickDensity
TickTopFunctions
      ProfAuto
ProfAutoExports  -> TickDensity
TickExportedFunctions
      ProfAuto
ProfAutoCalls    -> TickDensity
TickCallSites
      ProfAuto
_other           -> String -> TickDensity
forall a. HasCallStack => String -> a
panic String
"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

-- Strip ticks HsExpr

-- | Strip CoreTicks from an HsExpr
stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)
stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)
stripTicksTopHsExpr (XExpr (HsTick CoreTickish
t LHsExpr GhcTc
e)) = let ([CoreTickish]
ts, HsExpr GhcTc
body) = HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)
stripTicksTopHsExpr (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e)
                                            in (CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts, HsExpr GhcTc
body)
stripTicksTopHsExpr HsExpr GhcTc
e = ([], HsExpr GhcTc
e)

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

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

addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind (L SrcSpanAnnA
pos (XHsBindsLR bind :: XXHsBindsLR GhcTc GhcTc
bind@(AbsBinds { abs_binds :: AbsBinds -> LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
binds
                                                 , abs_exports :: AbsBinds -> [ABExport]
abs_exports = [ABExport]
abs_exports
                                                 }))) =
  (TickTransEnv -> TickTransEnv)
-> TM (LHsBind GhcTc) -> TM (LHsBind GhcTc)
forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
add_exports (TM (LHsBind GhcTc) -> TM (LHsBind GhcTc))
-> TM (LHsBind GhcTc) -> TM (LHsBind GhcTc)
forall a b. (a -> b) -> a -> b
$
    (TickTransEnv -> TickTransEnv)
-> TM (LHsBind GhcTc) -> TM (LHsBind GhcTc)
forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv TickTransEnv -> TickTransEnv
add_inlines (TM (LHsBind GhcTc) -> TM (LHsBind GhcTc))
-> TM (LHsBind GhcTc) -> TM (LHsBind GhcTc)
forall a b. (a -> b) -> a -> b
$ do
      binds' <- LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds LHsBinds GhcTc
binds
      return $ L pos $ XHsBindsLR $ bind { abs_binds = 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 = exports env `extendNameSetList`
                      [ idName mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , idName pid `elemNameSet` (exports env) ] }

   -- See Note [inline sccs]
   add_inlines :: TickTransEnv -> TickTransEnv
add_inlines TickTransEnv
env =
     TickTransEnv
env{ inlines = inlines env `extendVarSetList`
                      [ mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , isInlinePragma (idInlinePragma pid) ] }

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

  inline_ids <- liftM inlines getEnv
  -- See Note [inline sccs]
  let inline   = InlinePragma -> Bool
isInlinePragma (Id -> InlinePragma
idInlinePragma Id
id)
                 Bool -> Bool -> Bool
|| Id
id Id -> VarSet -> Bool
`elemVarSet` VarSet
inline_ids

  -- See Note [inline sccs]
  tickish <- tickishType `liftM` getEnv
  case tickish of { TickishType
ProfNotes | Bool
inline -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos HsBindLR GhcTc GhcTc
funBind); TickishType
_ -> do

  (fvs, mg) <-
        TM (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM
     (FreeVars,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. TM a -> TM (FreeVars, a)
getFreeVars (TM (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TM
      (FreeVars,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TM (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM
     (FreeVars,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
        String
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
forall a. String -> TM a -> TM a
addPathEntry String
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 HsBindLR GhcTc GhcTc
funBind)

  blackListed <- isBlackListed (locA pos)
  exported_names <- liftM exports 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 = HsBindLR GhcTc GhcTc -> Bool
isSimplePatBind HsBindLR GhcTc GhcTc
funBind
      toplev = [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
decl_path
      exported = Id -> Name
idName Id
id Name -> NameSet -> Bool
`elemNameSet` NameSet
exported_names

  tick <- if not blackListed &&
               shouldTickBind density toplev exported simple inline
             then
                bindTick density name (locA pos) fvs
             else
                return Nothing

  let 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 (:)
  return $ L pos $ funBind { fun_matches = mg
                           , fun_ext = second (tick `mbCons`) (fun_ext 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 (GenLocated SrcSpanAnnA (HsExpr 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 (L SrcSpanAnnA
pos (pat :: HsBindLR GhcTc GhcTc
pat@(PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
lhs
                                    , pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
rhs }))) = do

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

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

  (fvs, rhs') <- TM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM
     (FreeVars, GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. TM a -> TM (FreeVars, a)
getFreeVars (TM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TM
      (FreeVars, GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM
     (FreeVars, GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ String
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. String -> TM a -> TM a
addPathEntry String
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
-> Bool
-> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs Bool
False Bool
False Bool
False GRHSs GhcTc (LHsExpr GhcTc)
rhs
  let pat' = HsBindLR GhcTc GhcTc
pat { pat_rhs = rhs'}

  -- Should create ticks here?
  density <- getDensity
  decl_path <- getPathEntry
  let top_lev = [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
decl_path
  if not (shouldTickPatBind density top_lev)
    then return (L pos pat')
    else do

    let 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 (:)

    let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat'

    -- Allocate the ticks

    rhs_tick <- bindTick density name (locA pos) fvs
    let rhs_ticks = Maybe CoreTickish
rhs_tick Maybe CoreTickish -> [CoreTickish] -> [CoreTickish]
forall {a}. Maybe a -> [a] -> [a]
`mbCons` [CoreTickish]
initial_rhs_ticks

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

    return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') }

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

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


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

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

-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr e :: LHsExpr GhcTc
e@(L SrcSpanAnnA
pos HsExpr GhcTc
e0) = do
  d <- TM TickDensity
getDensity
  case d of
    TickDensity
TickForBreakPoints | HsExpr GhcTc -> Bool
isGoodBreakExpr HsExpr GhcTc
e0 -> TM (LHsExpr GhcTc)
TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tick_it
    TickDensity
TickForCoverage    | XExpr (ExpandedThingTc OrigStmt{} HsExpr GhcTc
_) <- HsExpr GhcTc
e0 -- expansion ticks are handled separately
                       -> TM (LHsExpr GhcTc)
TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
dont_tick_it
                       | Bool
otherwise -> TM (LHsExpr GhcTc)
TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tick_it
    TickDensity
TickCallSites      | HsExpr GhcTc -> Bool
isCallSite HsExpr GhcTc
e0      -> TM (LHsExpr GhcTc)
TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tick_it
    TickDensity
_other             -> TM (LHsExpr GhcTc)
TM (GenLocated SrcSpanAnnA (HsExpr 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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
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 HsExpr GhcTc
e0
   dont_tick_it :: TM (LHsExpr GhcTc)
dont_tick_it = LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e

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

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

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

-- General heuristic: expressions which are calls (do not denote
-- values) are good break points.
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) HsExpr GhcTc
_)) = Bool
False
isGoodBreakExpr HsExpr GhcTc
e = HsExpr GhcTc -> Bool
isCallSite HsExpr GhcTc
e

isCallSite :: HsExpr GhcTc -> Bool
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{}     = Bool
True
isCallSite HsAppType{} = Bool
True
isCallSite HsCase{}    = Bool
True
isCallSite (XExpr (ExpandedThingTc HsThingRn
_ HsExpr GhcTc
e))
  = HsExpr GhcTc -> Bool
isCallSite HsExpr GhcTc
e

-- NB: OpApp, SectionL, SectionR are all expanded out
isCallSite HsExpr GhcTc
_           = Bool
False

addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
oneOfMany e :: LHsExpr GhcTc
e@(L SrcSpanAnnA
pos HsExpr GhcTc
e0)
  = TickDensity
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
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 HsExpr GhcTc
e0)
        (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr Bool -> BoxLabel
boxLabel e :: LHsExpr GhcTc
e@(L SrcSpanAnnA
pos HsExpr GhcTc
e0)
  = TickDensity
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
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 HsExpr GhcTc
e0)
        (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)


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

addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr e :: HsExpr GhcTc
e@(HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
id))  = do Id -> TM ()
freeVar Id
id; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsUnboundVar {})   = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsRecSel XRecSel GhcTc
_ (FieldOcc XCFieldOcc GhcTc
id XRec GhcTc RdrName
_))   = do Id -> TM ()
freeVar XCFieldOcc GhcTc
Id
id; HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e

addTickHsExpr e :: HsExpr GhcTc
e@(HsIPVar {})            = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsOverLit {})          = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsOverLabel{})         = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsLit {})              = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsEmbTy {})            = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr (HsLam XLam GhcTc
x HsLamVariant
v MatchGroup GhcTc (LHsExpr GhcTc)
mg)            = (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> HsExpr GhcTc)
-> TM (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XLam GhcTc
-> HsLamVariant -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p.
XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
x HsLamVariant
v)
                                                (Bool
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup Bool
True MatchGroup GhcTc (LHsExpr GhcTc)
mg)
addTickHsExpr (HsApp XApp GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)          = (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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) = do
        e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e
        return (HsAppType x e' ty)
addTickHsExpr (OpApp XOpApp GhcTc
fix LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) =
        (DataConCantHappen
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> HsExpr GhcTc)
-> TM DataConCantHappen
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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 XOpApp GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
DataConCantHappen
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp
                (DataConCantHappen -> TM DataConCantHappen
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return XOpApp GhcTc
DataConCantHappen
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) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> SyntaxExprTc -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM SyntaxExprTc
-> 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) = do
        e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprEvalInner LHsExpr GhcTc
e
        return (HsPar x e')
addTickHsExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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 [HsTupArg GhcTc]
es Boxity
boxity) =
        ([HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc)
-> TM [HsTupArg 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 -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcTc
x)
                ((HsTupArg GhcTc -> TM (HsTupArg GhcTc))
-> [HsTupArg GhcTc] -> TM [HsTupArg GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg [HsTupArg GhcTc]
es)
                (Boxity -> TM Boxity
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return Boxity
boxity)
addTickHsExpr (ExplicitSum XExplicitSum GhcTc
ty Int
tag Int
arity LHsExpr GhcTc
e) = do
        e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
        return (ExplicitSum ty tag arity e')
addTickHsExpr (HsCase XCase GhcTc
x LHsExpr GhcTc
e MatchGroup GhcTc (LHsExpr GhcTc)
mgs) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcTc
x)
                ((Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr (CondBox -> Bool -> BoxLabel
BinBox CondBox
CondBinBox) LHsExpr GhcTc
e1)
                (Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
True LHsExpr GhcTc
e2)
                (Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
True LHsExpr GhcTc
e3)
addTickHsExpr (HsMultiIf XMultiIf GhcTc
ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
  = do { let isOneOfMany :: Bool
isOneOfMany = case [LGRHS GhcTc (LHsExpr GhcTc)]
alts of [LGRHS GhcTc (LHsExpr GhcTc)
_] -> Bool
False; [LGRHS GhcTc (LHsExpr GhcTc)]
_ -> Bool
True
       ; alts' <- (GenLocated
   EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TM
      (GenLocated
         EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> [GenLocated
      EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> TM
     [GenLocated
        EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)))
-> GenLocated EpAnnCO (GRHS GhcTc (LHsExpr GhcTc))
-> TM (GenLocated EpAnnCO (GRHS GhcTc (LHsExpr GhcTc)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenLocated EpAnnCO a -> f (GenLocated EpAnnCO b)
traverse ((GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)))
 -> GenLocated EpAnnCO (GRHS GhcTc (LHsExpr GhcTc))
 -> TM (GenLocated EpAnnCO (GRHS GhcTc (LHsExpr GhcTc))))
-> (GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)))
-> GenLocated EpAnnCO (GRHS GhcTc (LHsExpr GhcTc))
-> TM (GenLocated EpAnnCO (GRHS GhcTc (LHsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS Bool
isOneOfMany Bool
False Bool
False) [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
   EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts
       ; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet XLet GhcTc
x HsLocalBinds GhcTc
binds LHsExpr GhcTc
e) =
        [Id] -> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a. [Id] -> TM a -> TM a
bindLocals (CollectFlag GhcTc -> HsLocalBinds GhcTc -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcTc
binds) (TM (HsExpr GhcTc) -> TM (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ do
          binds' <- HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
binds -- to think about: !patterns.
          e' <- addTickLHsExprLetBody e
          return (HsLet x binds' e')
addTickHsExpr (ExplicitList XExplicitList GhcTc
ty [LHsExpr GhcTc]
es)
  = (Type -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> HsExpr GhcTc)
-> TM Type
-> TM [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 XExplicitList GhcTc -> [LHsExpr GhcTc] -> HsExpr GhcTc
Type -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> HsExpr GhcTc
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList (Type -> TM Type
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return XExplicitList GhcTc
Type
ty) ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> TM [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
addTickLHsExpr) [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
es)

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 (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr 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 { rec_binds' <- HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
addTickHsRecordBinds HsRecordBinds GhcTc
rec_binds
       ; return (expr { rcon_flds = 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 -> LHsRecUpdFields p
rupd_flds = upd :: LHsRecUpdFields GhcTc
upd@(RegularRecUpdFields { recUpdFields :: forall p. LHsRecUpdFields p -> [LHsRecUpdField p p]
recUpdFields = [LHsRecUpdField GhcTc GhcTc]
flds }) })
  = do { e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
       ; flds' <- mapM addTickHsRecField flds
       ; return (expr { rupd_expr = e', rupd_flds = upd { recUpdFields = flds' } }) }
addTickHsExpr expr :: HsExpr GhcTc
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
e
                              , rupd_flds :: forall p. HsExpr p -> LHsRecUpdFields p
rupd_flds = upd :: LHsRecUpdFields GhcTc
upd@(OverloadedRecUpdFields { olRecUpdFields :: forall p. LHsRecUpdFields p -> [LHsRecUpdProj p]
olRecUpdFields = [LHsRecUpdProj GhcTc]
flds } ) })
  = do { e' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e
       ; flds' <- mapM addTickHsRecField flds
       ; return (expr { rupd_expr = e', rupd_flds = upd { olRecUpdFields = flds' } }) }

addTickHsExpr (ExprWithTySig XExprWithTySig GhcTc
x LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
ty) =
        (NoExtField
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> HsWildCardBndrs
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
 -> HsExpr GhcTc)
-> TM NoExtField
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM
     (HsWildCardBndrs
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (HsSigType (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 XExprWithTySig GhcTc
-> LHsExpr GhcTc -> LHsSigWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
NoExtField
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> HsWildCardBndrs
     (GhcPass 'Renamed)
     (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> HsExpr GhcTc
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig
                (NoExtField -> TM NoExtField
forall a. a -> TM a
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
                (HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> TM
     (HsWildCardBndrs
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))))
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsSigWcType (NoGhcTc GhcTc)
HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
ty)
addTickHsExpr (ArithSeq XArithSeq GhcTc
ty Maybe (SyntaxExpr GhcTc)
wit ArithSeqInfo GhcTc
arith_seq) =
        (HsExpr GhcTc
 -> Maybe SyntaxExprTc -> ArithSeqInfo GhcTc -> HsExpr GhcTc)
-> TM (HsExpr GhcTc)
-> TM (Maybe SyntaxExprTc)
-> 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 XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
HsExpr GhcTc
-> Maybe SyntaxExprTc -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq
                (HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return XArithSeq GhcTc
HsExpr GhcTc
ty)
                (Maybe SyntaxExprTc -> TM (Maybe SyntaxExprTc)
addTickWit Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit)
                (ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo ArithSeqInfo GhcTc
arith_seq)
             where addTickWit :: Maybe SyntaxExprTc -> TM (Maybe SyntaxExprTc)
addTickWit Maybe SyntaxExprTc
Nothing = Maybe SyntaxExprTc -> TM (Maybe SyntaxExprTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
                   addTickWit (Just SyntaxExprTc
fl) = do fl' <- SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
SyntaxExprTc
fl
                                             return (Just fl')

addTickHsExpr (HsPragE XPragE GhcTc
x HsPragE GhcTc
p LHsExpr GhcTc
e) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcTc
x HsPragE GhcTc
p) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
addTickHsExpr e :: HsExpr GhcTc
e@(HsTypedBracket {})  = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsUntypedBracket{}) = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsTypedSplice{})    = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsUntypedSplice{})  = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsGetField {})      = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr e :: HsExpr GhcTc
e@(HsProjection {})    = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
addTickHsExpr (HsProc XProc GhcTc
x LPat GhcTc
pat LHsCmdTop GhcTc
cmdtop) =
        (GenLocated SrcSpanAnnA (Pat GhcTc)
 -> GenLocated EpAnnCO (HsCmdTop GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (Pat GhcTc))
-> TM (GenLocated EpAnnCO (HsCmdTop 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)
                ((HsCmdTop GhcTc -> TM (HsCmdTop GhcTc))
-> GenLocated EpAnnCO (HsCmdTop GhcTc)
-> TM (GenLocated EpAnnCO (HsCmdTop GhcTc))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenLocated EpAnnCO a -> f (GenLocated EpAnnCO b)
traverse (HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop) LHsCmdTop GhcTc
GenLocated EpAnnCO (HsCmdTop GhcTc)
cmdtop)
addTickHsExpr (XExpr (WrapExpr (HsWrap HsWrapper
w HsExpr GhcTc
e))) =
        (HsExpr GhcTc -> HsExpr GhcTc)
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (HsExpr GhcTc -> XXExprGhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsWrap HsExpr -> XXExprGhcTc
WrapExpr (HsWrap HsExpr -> XXExprGhcTc)
-> (HsExpr GhcTc -> HsWrap HsExpr) -> HsExpr GhcTc -> XXExprGhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsWrapper -> HsExpr GhcTc -> HsWrap HsExpr
forall (hs_syn :: * -> *).
HsWrapper -> hs_syn GhcTc -> HsWrap hs_syn
HsWrap HsWrapper
w) (TM (HsExpr GhcTc) -> TM (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
              (HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e)        -- Explicitly no tick on inside
addTickHsExpr (XExpr (ExpandedThingTc HsThingRn
o HsExpr GhcTc
e)) = HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpanded HsThingRn
o HsExpr GhcTc
e

addTickHsExpr e :: HsExpr GhcTc
e@(XExpr (ConLikeTc {})) = HsExpr GhcTc -> TM (HsExpr GhcTc)
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
  -- We used to do a freeVar on a pat-syn builder, but actually
  -- such builders are never in the inScope env, which
  -- doesn't include top level bindings

-- We might encounter existing ticks (multiple Coverage passes)
addTickHsExpr (XExpr (HsTick CoreTickish
t LHsExpr GhcTc
e)) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> XXExprGhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> LHsExpr GhcTc -> XXExprGhcTc
HsTick CoreTickish
t) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e)
addTickHsExpr (XExpr (HsBinTick Int
t0 Int
t1 LHsExpr GhcTc
e)) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> XXExprGhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> LHsExpr GhcTc -> XXExprGhcTc
HsBinTick Int
t0 Int
t1) (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
e)

addTickHsExpr (HsDo XDo GhcTc
srcloc HsDoFlavour
cxt (L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts))
  = do { (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]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts (() -> TM ()
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; return (HsDo srcloc cxt (L l stmts')) }
  where
        forQual :: Maybe (Bool -> BoxLabel)
forQual = case HsDoFlavour
cxt of
                    HsDoFlavour
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
                    HsDoFlavour
_        -> Maybe (Bool -> BoxLabel)
forall a. Maybe a
Nothing

addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpanded o :: HsThingRn
o@(OrigStmt (L SrcSpanAnnA
pos LastStmt{})) HsExpr GhcTc
e
  -- LastStmt always gets a tick for breakpoint and hpc coverage
  = do d <- TM TickDensity
getDensity
       case d of
          TickDensity
TickForCoverage    -> (HsExpr GhcTc -> HsExpr GhcTc)
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (HsExpr GhcTc -> XXExprGhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsThingRn -> HsExpr GhcTc -> XXExprGhcTc
ExpandedThingTc HsThingRn
o) (TM (HsExpr GhcTc) -> TM (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
tick_it HsExpr GhcTc
e
          TickDensity
TickForBreakPoints -> (HsExpr GhcTc -> HsExpr GhcTc)
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (HsExpr GhcTc -> XXExprGhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsThingRn -> HsExpr GhcTc -> XXExprGhcTc
ExpandedThingTc HsThingRn
o) (TM (HsExpr GhcTc) -> TM (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
tick_it HsExpr GhcTc
e
          TickDensity
_                  -> (HsExpr GhcTc -> HsExpr GhcTc)
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (HsExpr GhcTc -> XXExprGhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsThingRn -> HsExpr GhcTc -> XXExprGhcTc
ExpandedThingTc HsThingRn
o) (TM (HsExpr GhcTc) -> TM (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e
  where
    tick_it :: HsExpr GhcTc -> TM (HsExpr GhcTc)
tick_it HsExpr GhcTc
e  = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
False) Bool
False Bool
False (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
pos)
                               (HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e)
addTickHsExpanded HsThingRn
o HsExpr GhcTc
e
  = (HsExpr GhcTc -> HsExpr GhcTc)
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (HsExpr GhcTc -> XXExprGhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsThingRn -> HsExpr GhcTc -> XXExprGhcTc
ExpandedThingTc HsThingRn
o) (TM (HsExpr GhcTc) -> TM (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr HsExpr GhcTc
e


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


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

addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} ->  Match GhcTc (LHsExpr GhcTc)
             -> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch :: Bool
-> Bool
-> Bool
-> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch Bool
isOneOfMany Bool
isLambda Bool
isDoExp 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 (CollectFlag GhcTc -> [LPat GhcTc] -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders [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' <- Bool
-> Bool
-> Bool
-> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs Bool
isOneOfMany Bool
isLambda Bool
isDoExp GRHSs GhcTc (LHsExpr GhcTc)
gRHSs
    return $ match { m_grhss = gRHSs' }

addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs :: Bool
-> Bool
-> Bool
-> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs Bool
isOneOfMany Bool
isLambda Bool
isDoExp (GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
x [LGRHS GhcTc (LHsExpr GhcTc)]
guarded HsLocalBinds GhcTc
local_binds) =
  [Id]
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. [Id] -> TM a -> TM a
bindLocals [IdP GhcTc]
[Id]
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
    local_binds' <- HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
local_binds
    guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded
    return $ GRHSs x guarded' local_binds'
  where
    binders :: [IdP GhcTc]
binders = CollectFlag GhcTc -> HsLocalBinds GhcTc -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcTc
local_binds

addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
            -> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS :: Bool
-> Bool
-> Bool
-> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS Bool
isOneOfMany Bool
isLambda Bool
isDoExp (GRHS XCGRHS GhcTc (LHsExpr GhcTc)
x [ExprLStmt GhcTc]
stmts LHsExpr GhcTc
expr) = do
  (stmts',expr') <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc]
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM ([ExprLStmt GhcTc], GenLocated SrcSpanAnnA (HsExpr 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 -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody Bool
isOneOfMany Bool
isLambda Bool
isDoExp LHsExpr GhcTc
expr)
  return $ GRHS x stmts' expr'

addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody Bool
isOneOfMany Bool
isLambda Bool
isDoExp expr :: LHsExpr GhcTc
expr@(L SrcSpanAnnA
pos HsExpr GhcTc
e0) = do
  d <- TM TickDensity
getDensity
  case d of
    TickDensity
TickForBreakPoints
      | Bool
isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`
      -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
expr
      | Bool
otherwise
      -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS LHsExpr GhcTc
expr
    TickDensity
TickForCoverage
      | Bool
isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`
      -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever LHsExpr GhcTc
expr
      | Bool
otherwise
      -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt Bool
isOneOfMany LHsExpr GhcTc
expr
    TickDensity
TickAllFunctions | Bool
isLambda ->
       String
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. String -> TM a -> TM a
addPathEntry String
"\\" (TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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-} (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
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 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
  (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 a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  return stmts

addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
               -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' :: forall a.
Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a)
addTickLStmts' Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
lstmts TM a
res
  = [Id] -> TM ([ExprLStmt GhcTc], a) -> TM ([ExprLStmt GhcTc], a)
forall a. [Id] -> TM a -> TM a
bindLocals (CollectFlag GhcTc
-> [LStmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders [ExprLStmt GhcTc]
[LStmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr 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 { lstmts' <- (GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TM
      (GenLocated
         SrcSpanAnnA
         (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> TM
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> TM (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnA a -> f (GenLocated SrcSpanAnnA b)
traverse (Maybe (Bool -> BoxLabel)
-> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
addTickStmt Maybe (Bool -> BoxLabel)
isGuard)) [ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
lstmts
       ; a <- res
       ; return (lstmts', a) }

addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
            -> TM (Stmt GhcTc (LHsExpr GhcTc))
addTickStmt :: Maybe (Bool -> BoxLabel)
-> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))
addTickStmt Maybe (Bool -> BoxLabel)
_isGuard (LastStmt XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
x LHsExpr GhcTc
e Maybe Bool
noret SyntaxExpr GhcTc
ret) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> Maybe Bool
 -> SyntaxExprTc
 -> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (Maybe Bool)
-> TM SyntaxExprTc
-> TM (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
x)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)
                (Maybe Bool -> TM (Maybe Bool)
forall a. a -> TM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
noret)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
ret)
addTickStmt Maybe (Bool -> BoxLabel)
_isGuard (BindStmt XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
xbs LPat GhcTc
pat LHsExpr GhcTc
e) =
        (SyntaxExprTc
 -> Maybe SyntaxExprTc
 -> GenLocated SrcSpanAnnA (Pat GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM SyntaxExprTc
-> TM (Maybe SyntaxExprTc)
-> TM (GenLocated SrcSpanAnnA (Pat GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (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 (\SyntaxExprTc
b Maybe SyntaxExprTc
f -> XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt (XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> LPat GhcTc
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ XBindStmtTc
                    { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
SyntaxExprTc
b
                    , xbstc_boundResultType :: Type
xbstc_boundResultType = XBindStmtTc -> Type
xbstc_boundResultType XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
XBindStmtTc
xbs
                    , xbstc_boundResultMult :: Type
xbstc_boundResultMult = XBindStmtTc -> Type
xbstc_boundResultMult XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
XBindStmtTc
xbs
                    , xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp = Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
f
                    })
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
XBindStmtTc
xbs))
                ((SyntaxExprTc -> TM SyntaxExprTc)
-> Maybe SyntaxExprTc -> TM (Maybe SyntaxExprTc)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan) (XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
XBindStmtTc
xbs))
                (LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat)
                (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS LHsExpr GhcTc
e)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
x LHsExpr GhcTc
e SyntaxExpr GhcTc
bind' SyntaxExpr GhcTc
guard') =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> SyntaxExprTc
 -> SyntaxExprTc
 -> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM SyntaxExprTc
-> TM SyntaxExprTc
-> TM (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
x)
                (Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick Maybe (Bool -> BoxLabel)
isGuard LHsExpr GhcTc
e)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bind')
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
guard')
addTickStmt Maybe (Bool -> BoxLabel)
_isGuard (LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
x HsLocalBinds GhcTc
binds) =
        (HsLocalBinds GhcTc
 -> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM (HsLocalBinds GhcTc)
-> TM (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XLetStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsLocalBinds GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
XLetStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
x)
                (HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
binds)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (ParStmt XParStmt GhcTc GhcTc (LHsExpr GhcTc)
x [ParStmtBlock GhcTc GhcTc]
pairs HsExpr GhcTc
mzipExpr SyntaxExpr GhcTc
bindExpr) =
    ([ParStmtBlock GhcTc GhcTc]
 -> HsExpr GhcTc
 -> SyntaxExprTc
 -> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TM [ParStmtBlock GhcTc GhcTc]
-> TM (HsExpr GhcTc)
-> TM SyntaxExprTc
-> TM (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [ParStmtBlock GhcTc GhcTc]
-> HsExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr 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)
XParStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe (Bool -> BoxLabel)
-> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders Maybe (Bool -> BoxLabel)
isGuard) [ParStmtBlock GhcTc GhcTc]
pairs)
        (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
hpcSrcSpan) HsExpr GhcTc
mzipExpr))
        (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bindExpr)
addTickStmt Maybe (Bool -> BoxLabel)
isGuard (ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join) = do
    args' <- ((SyntaxExprTc, ApplicativeArg GhcTc)
 -> TM (SyntaxExprTc, ApplicativeArg GhcTc))
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> TM [(SyntaxExprTc, ApplicativeArg GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe (Bool -> BoxLabel)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg Maybe (Bool -> BoxLabel)
isGuard) [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
args
    return (ApplicativeStmt body_ty args' 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
    t_s <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc] -> TM [ExprLStmt GhcTc]
addTickLStmts Maybe (Bool -> BoxLabel)
isGuard [ExprLStmt GhcTc]
stmts
    t_y <- traverse  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
    t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))
    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }

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

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

addTickApplicativeArg
  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg :: Maybe (Bool -> BoxLabel)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg Maybe (Bool -> BoxLabel)
isGuard (SyntaxExpr GhcTc
op, ApplicativeArg GhcTc
arg) =
  (SyntaxExprTc
 -> ApplicativeArg GhcTc -> (SyntaxExprTc, ApplicativeArg GhcTc))
-> TM SyntaxExprTc
-> TM (ApplicativeArg GhcTc)
-> TM (SyntaxExprTc, 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
m_fail LPat GhcTc
pat LHsExpr GhcTc
expr Bool
isBody) =
    Maybe SyntaxExprTc
-> LPat GhcTc -> LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc
XApplicativeArgOne GhcTc
-> LPat GhcTc -> LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc
forall idL.
XApplicativeArgOne idL
-> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL
ApplicativeArgOne
      (Maybe SyntaxExprTc
 -> LPat GhcTc -> LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc)
-> TM (Maybe SyntaxExprTc)
-> TM (LPat GhcTc -> LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SyntaxExprTc -> TM SyntaxExprTc)
-> Maybe SyntaxExprTc -> TM (Maybe SyntaxExprTc)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan) Maybe SyntaxExprTc
XApplicativeArgOne GhcTc
m_fail
      TM (LPat GhcTc -> LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc)
-> TM (LPat GhcTc)
-> TM (LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc)
forall a b. TM (a -> b) -> TM a -> TM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat
      TM (LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc)
-> TM (LHsExpr GhcTc) -> TM (Bool -> ApplicativeArg GhcTc)
forall a b. TM (a -> b) -> TM a -> TM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
expr
      TM (Bool -> ApplicativeArg GhcTc)
-> TM Bool -> TM (ApplicativeArg GhcTc)
forall a b. TM (a -> b) -> TM a -> TM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> TM Bool
forall a. a -> TM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isBody
  addTickArg (ApplicativeArgMany XApplicativeArgMany GhcTc
x [ExprLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat HsDoFlavour
ctxt) =
    (XApplicativeArgMany GhcTc
-> [ExprLStmt GhcTc]
-> HsExpr GhcTc
-> LPat GhcTc
-> HsDoFlavour
-> ApplicativeArg GhcTc
forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsDoFlavour
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcTc
x)
      ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
 -> HsExpr GhcTc
 -> GenLocated SrcSpanAnnA (Pat GhcTc)
 -> HsDoFlavour
 -> ApplicativeArg GhcTc)
-> TM
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> TM
     (HsExpr GhcTc
      -> GenLocated SrcSpanAnnA (Pat GhcTc)
      -> HsDoFlavour
      -> 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
   -> GenLocated SrcSpanAnnA (Pat GhcTc)
   -> HsDoFlavour
   -> ApplicativeArg GhcTc)
-> TM (HsExpr GhcTc)
-> TM
     (GenLocated SrcSpanAnnA (Pat GhcTc)
      -> HsDoFlavour -> ApplicativeArg GhcTc)
forall a b. TM (a -> b) -> TM a -> TM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> TM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
hpcSrcSpan) HsExpr GhcTc
ret))
      TM
  (GenLocated SrcSpanAnnA (Pat GhcTc)
   -> HsDoFlavour -> ApplicativeArg GhcTc)
-> TM (GenLocated SrcSpanAnnA (Pat GhcTc))
-> TM (HsDoFlavour -> ApplicativeArg GhcTc)
forall a b. TM (a -> b) -> TM a -> TM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat
      TM (HsDoFlavour -> ApplicativeArg GhcTc)
-> TM HsDoFlavour -> TM (ApplicativeArg GhcTc)
forall a b. TM (a -> b) -> TM a -> TM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HsDoFlavour -> TM HsDoFlavour
forall a. a -> TM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsDoFlavour
ctxt

addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                      -> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel)
-> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders Maybe (Bool -> BoxLabel)
isGuard (ParStmtBlock XParStmtBlock GhcTc GhcTc
x [ExprLStmt GhcTc]
stmts [IdP GhcTc]
ids SyntaxExpr GhcTc
returnExpr) =
    ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
 -> [Id] -> SyntaxExprTc -> ParStmtBlock GhcTc GhcTc)
-> TM
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> TM [Id]
-> TM SyntaxExprTc
-> 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 a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return [IdP GhcTc]
[Id]
ids)
        (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
returnExpr)

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

addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
                  -> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds :: forall (a :: Pass) (b :: Pass).
HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig (GhcPass 'Renamed)]
sigs)) = do
        b <- ([(RecFlag, LHsBinds GhcTc)]
 -> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
 -> NHsValBindsLR GhcTc)
-> TM [(RecFlag, LHsBinds GhcTc)]
-> TM [GenLocated SrcSpanAnnA (Sig (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
[(RecFlag, LHsBinds GhcTc)]
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> NHsValBindsLR GhcTc
forall idL.
[(RecFlag, LHsBinds idL)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR idL
NValBinds
                (((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
 -> TM (RecFlag, LHsBinds GhcTc))
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> TM [(RecFlag, LHsBinds GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (RecFlag
rec,Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc 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 a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return RecFlag
rec)
                                        (LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds'))
                        [(RecFlag, LHsBinds GhcTc)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds)
                ([GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> TM [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs)
        return $ XValBindsLR b
addTickHsValBinds HsValBindsLR GhcTc (GhcPass a)
_ = String -> TM (HsValBindsLR GhcTc (GhcPass b))
forall a. HasCallStack => String -> a
panic String
"addTickHsValBinds"

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

addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind (IPBind XCIPBind GhcTc
x XRec GhcTc HsIPName
nm LHsExpr GhcTc
e) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> IPBind GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> TM (IPBind GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XCIPBind GhcTc
-> XRec GhcTc HsIPName -> LHsExpr GhcTc -> IPBind GhcTc
forall id.
XCIPBind id -> XRec id HsIPName -> LHsExpr id -> IPBind id
IPBind XCIPBind GhcTc
x XRec GhcTc HsIPName
nm)
               (LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
e)

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

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

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

addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (L SrcSpanAnnA
pos HsCmd GhcTc
c0) = do
        c1 <- HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd HsCmd GhcTc
c0
        return $ L pos c1

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

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

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

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

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

addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch match :: Match GhcTc (LHsCmd GhcTc)
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcTc]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (LHsCmd GhcTc)
gRHSs }) =
  [Id]
-> TM (Match GhcTc (LHsCmd GhcTc))
-> TM (Match GhcTc (LHsCmd GhcTc))
forall a. [Id] -> TM a -> TM a
bindLocals (CollectFlag GhcTc -> [LPat GhcTc] -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders [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' <- GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs GRHSs GhcTc (LHsCmd GhcTc)
gRHSs
    return $ match { m_grhss = gRHSs' }

addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs (GRHSs XCGRHSs GhcTc (LHsCmd GhcTc)
x [LGRHS GhcTc (LHsCmd GhcTc)]
guarded HsLocalBinds GhcTc
local_binds) =
  [Id]
-> TM (GRHSs GhcTc (LHsCmd GhcTc))
-> TM (GRHSs GhcTc (LHsCmd GhcTc))
forall a. [Id] -> TM a -> TM a
bindLocals [IdP GhcTc]
[Id]
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
    local_binds' <- HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
local_binds
    guarded' <- mapM (traverse addTickCmdGRHS) guarded
    return $ GRHSs x guarded' local_binds'
  where
    binders :: [IdP GhcTc]
binders = CollectFlag GhcTc -> HsLocalBinds GhcTc -> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcTc
local_binds

addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
addTickCmdGRHS (GRHS XCGRHS GhcTc (LHsCmd GhcTc)
x [ExprLStmt GhcTc]
stmts LHsCmd GhcTc
cmd)
  = do { (stmts',expr') <- Maybe (Bool -> BoxLabel)
-> [ExprLStmt GhcTc]
-> TM (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> TM ([ExprLStmt GhcTc], GenLocated SrcSpanAnnA (HsCmd 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)
       ; return $ GRHS x stmts' expr' }

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

addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
addTickLCmdStmts' :: forall a. [CmdLStmt GhcTc] -> TM a -> TM ([CmdLStmt GhcTc], a)
addTickLCmdStmts' [CmdLStmt GhcTc]
lstmts TM a
res
  = [Id] -> TM ([CmdLStmt GhcTc], a) -> TM ([CmdLStmt GhcTc], a)
forall a. [Id] -> TM a -> TM a
bindLocals [IdP GhcTc]
[Id]
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
        lstmts' <- (GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
 -> TM
      (GenLocated
         SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))))
-> [GenLocated
      SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
-> TM
     [GenLocated
        SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
 -> TM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))))
-> GenLocated
     SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
-> TM
     (GenLocated
        SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnA a -> f (GenLocated SrcSpanAnnA b)
traverse Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> TM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
addTickCmdStmt) [CmdLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
lstmts
        a <- res
        return (lstmts', a)
  where
        binders :: [IdP GhcTc]
binders = CollectFlag GhcTc
-> [LStmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
-> [IdP GhcTc]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders [CmdLStmt GhcTc]
[LStmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd 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) =
        (GenLocated SrcSpanAnnA (Pat GhcTc)
 -> GenLocated SrcSpanAnnA (HsCmd GhcTc)
 -> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
-> TM (GenLocated SrcSpanAnnA (Pat GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> TM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> LPat GhcTc
-> GenLocated SrcSpanAnnA (HsCmd GhcTc)
-> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTc GhcTc (LHsCmd GhcTc)
XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
x)
                (LPat GhcTc -> TM (LPat GhcTc)
addTickLPat LPat GhcTc
pat)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
addTickCmdStmt (LastStmt XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
x LHsCmd GhcTc
c Maybe Bool
noret SyntaxExpr GhcTc
ret) =
        (GenLocated SrcSpanAnnA (HsCmd GhcTc)
 -> Maybe Bool
 -> SyntaxExprTc
 -> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
-> TM (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> TM (Maybe Bool)
-> TM SyntaxExprTc
-> TM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd 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 (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> GenLocated SrcSpanAnnA (HsCmd GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
x)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
                (Maybe Bool -> TM (Maybe Bool)
forall a. a -> TM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
noret)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
ret)
addTickCmdStmt (BodyStmt XBodyStmt GhcTc GhcTc (LHsCmd GhcTc)
x LHsCmd GhcTc
c SyntaxExpr GhcTc
bind' SyntaxExpr GhcTc
guard') =
        (GenLocated SrcSpanAnnA (HsCmd GhcTc)
 -> SyntaxExprTc
 -> SyntaxExprTc
 -> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
-> TM (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> TM SyntaxExprTc
-> TM SyntaxExprTc
-> TM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd 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 (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> GenLocated SrcSpanAnnA (HsCmd GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LHsCmd GhcTc)
XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
x)
                (LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd LHsCmd GhcTc
c)
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
bind')
                (SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr SrcSpan
hpcSrcSpan SyntaxExpr GhcTc
guard')
addTickCmdStmt (LetStmt XLetStmt GhcTc GhcTc (LHsCmd GhcTc)
x HsLocalBinds GhcTc
binds) =
        (HsLocalBinds GhcTc
 -> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
-> TM (HsLocalBinds GhcTc)
-> TM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (XLetStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> HsLocalBinds GhcTc
-> Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcTc GhcTc (LHsCmd GhcTc)
XLetStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
x)
                (HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds HsLocalBinds GhcTc
binds)
addTickCmdStmt stmt :: Stmt GhcTc (LHsCmd GhcTc)
stmt@(RecStmt {})
  = do { stmts' <- [CmdLStmt GhcTc] -> TM [CmdLStmt GhcTc]
addTickLCmdStmts (GenLocated SrcSpanAnnL [CmdLStmt GhcTc] -> [CmdLStmt GhcTc]
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnL [CmdLStmt GhcTc] -> [CmdLStmt GhcTc])
-> GenLocated SrcSpanAnnL [CmdLStmt GhcTc] -> [CmdLStmt GhcTc]
forall a b. (a -> b) -> a -> b
$ Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> XRec
     GhcTc [LStmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts Stmt GhcTc (LHsCmd GhcTc)
Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
stmt)
       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTickCmdStmt ApplicativeStmt{} =
  String -> TM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))
forall a. HasCallStack => String -> a
panic String
"ToDo: addTickCmdStmt ApplicativeLastStmt"

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

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

addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)
                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))
addTickHsRecField :: forall id.
LHsFieldBind GhcTc id (LHsExpr GhcTc)
-> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))
addTickHsRecField (L SrcSpanAnnA
l (HsFieldBind XHsFieldBind id
x id
id GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr Bool
pun))
        = do { expr' <- LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr
             ; return (L l (HsFieldBind x id expr' pun)) }

addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
addTickArithSeqInfo (From LHsExpr GhcTc
e1) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> ArithSeqInfo GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (ArithSeqInfo GhcTc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LHsExpr GhcTc -> ArithSeqInfo GhcTc
GenLocated SrcSpanAnnA (HsExpr 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) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> ArithSeqInfo GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr 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) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> ArithSeqInfo GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr 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) =
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> ArithSeqInfo GhcTc)
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr 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 -> SizedSeq Tick
ticks       :: !(SizedSeq Tick)
                         , TickTransState -> CostCentreState
ccIndices   :: !CostCentreState
                         }

initTTState :: TickTransState
initTTState :: TickTransState
initTTState = TT { ticks :: SizedSeq Tick
ticks        = SizedSeq Tick
forall a. SizedSeq a
emptySS
                 , ccIndices :: CostCentreState
ccIndices    = CostCentreState
newCostCentreState
                 }

addMixEntry :: Tick -> TM Int
addMixEntry :: Tick -> TM Int
addMixEntry Tick
ent = do
  c <- Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> (TickTransState -> Word) -> TickTransState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SizedSeq Tick -> Word
forall a. SizedSeq a -> Word
sizeSS (SizedSeq Tick -> Word)
-> (TickTransState -> SizedSeq Tick) -> TickTransState -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickTransState -> SizedSeq Tick
ticks (TickTransState -> Int) -> TM TickTransState -> TM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TM TickTransState
getState
  setState $ \TickTransState
st ->
    TickTransState
st { ticks = addToSS (ticks st) ent
       }
  return c

data TickTransEnv = TTE { TickTransEnv -> FastString
fileName     :: FastString
                        , TickTransEnv -> TickDensity
density      :: TickDensity
                        , TickTransEnv -> Bool
tte_countEntries :: !Bool
                          -- ^ Whether the number of times functions are
                          -- entered should be counted.
                        , TickTransEnv -> NameSet
exports      :: NameSet
                        , TickTransEnv -> VarSet
inlines      :: VarSet
                        , TickTransEnv -> [String]
declPath     :: [String]
                        , TickTransEnv -> VarSet
inScope      :: VarSet
                        , TickTransEnv -> Set RealSrcSpan
blackList    :: Set RealSrcSpan
                        , TickTransEnv -> Module
this_mod     :: Module
                        , TickTransEnv -> TickishType
tickishType  :: TickishType
                        }

--      deriving Show

-- | Reasons why we need ticks,
data TickishType
  -- | For profiling
  = ProfNotes
  -- | For Haskell Program Coverage
  | HpcTicks
  -- | For ByteCode interpreter break points
  | Breakpoints
  -- | For source notes
  | SourceNotes
  deriving (TickishType -> TickishType -> Bool
(TickishType -> TickishType -> Bool)
-> (TickishType -> TickishType -> Bool) -> Eq TickishType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TickishType -> TickishType -> Bool
== :: TickishType -> TickishType -> Bool
$c/= :: TickishType -> TickishType -> Bool
/= :: TickishType -> TickishType -> Bool
Eq)

-- | 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 { forall a.
TM a
-> TickTransEnv -> TickTransState -> (a, FreeVars, TickTransState)
unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
    deriving ((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
$cfmap :: forall a b. (a -> b) -> TM a -> TM b
fmap :: forall a b. (a -> b) -> TM a -> TM b
$c<$ :: forall a b. a -> TM b -> TM a
<$ :: forall a b. a -> TM b -> TM a
Functor)
        -- a combination of a state monad (TickTransState) and a writer
        -- monad (FreeVars).

instance Applicative TM where
    pure :: forall a. a -> TM a
pure a
a = (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)
    <*> :: forall a b. 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) >>= :: forall a b. 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)


-- | 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 = 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 :: forall a. (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 :: forall a. TickDensity -> TM a -> TM a -> TM a
ifDensity TickDensity
d TM a
th TM a
el = do d0 <- TM TickDensity
getDensity; if d == d0 then th else el

getFreeVars :: TM a -> TM (FreeVars, a)
getFreeVars :: forall a. 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 :: forall a. String -> TM a -> TM a
addPathEntry String
nm = (TickTransEnv -> TickTransEnv) -> TM a -> TM a
forall a. (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv (\ TickTransEnv
env -> TickTransEnv
env { declPath = declPath env ++ [nm] })

getPathEntry :: TM [String]
getPathEntry :: TM [String]
getPathEntry = TickTransEnv -> [String]
declPath (TickTransEnv -> [String]) -> TM TickTransEnv -> TM [String]
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
_ Maybe BufSpan
_) = SrcSpan -> SrcLoc
srcSpanStart SrcSpan
pos SrcLoc -> SrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
pos
isGoodSrcSpan' (UnhelpfulSpan UnhelpfulSpanReason
_) = Bool
False

isGoodTickSrcSpan :: SrcSpan -> TM Bool
isGoodTickSrcSpan :: SrcSpan -> TM Bool
isGoodTickSrcSpan SrcSpan
pos = do
  file_name <- TM FastString
getFileName
  tickish <- tickishType `liftM` getEnv
  let need_same_file = TickishType -> Bool
tickSameFileOnly TickishType
tickish
      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
  return (isGoodSrcSpan' pos && (not need_same_file || same_file))

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

bindLocals :: [Id] -> TM a -> TM a
bindLocals :: forall a. [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 = inScope env `extendVarSetList` 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 (RealSrcSpan RealSrcSpan
pos Maybe BufSpan
_) = (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 -> (RealSrcSpan -> Set RealSrcSpan -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member RealSrcSpan
pos (TickTransEnv -> Set RealSrcSpan
blackList TickTransEnv
env), FreeVars
noFVs, TickTransState
st)
isBlackListed (UnhelpfulSpan UnhelpfulSpanReason
_) = Bool -> TM Bool
forall a. a -> TM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
             -> TM (LHsExpr GhcTc)
allocTickBox :: BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos TM (HsExpr GhcTc)
m =
  SrcSpan
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan SrcSpan
pos (do
    (fvs, e) <- TM (HsExpr GhcTc) -> TM (FreeVars, HsExpr GhcTc)
forall a. TM a -> TM (FreeVars, a)
getFreeVars TM (HsExpr GhcTc)
m
    env <- getEnv
    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e)))
  (do
    e <- TM (HsExpr GhcTc)
m
    return (L (noAnnSrcSpan pos) e)
  )

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


mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
          -> TM CoreTickish
mkTickish :: BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> FreeVars
-> [String]
-> TM CoreTickish
mkTickish BoxLabel
boxLabel Bool
countEntries Bool
topOnly SrcSpan
pos FreeVars
fvs [String]
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
. Type -> Bool
mightBeUnliftedType (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]
nonDetOccEnvElts FreeVars
fvs
          -- unlifted types cause two problems here:
          --   * we can't bind them  at the GHCi prompt
          --     (bindLocalsAtBreakpoint already filters them out),
          --   * the simplifier might try to substitute a literal for
          --     the Id, and we can't handle that.

      me :: Tick
me = Tick
        { tick_loc :: SrcSpan
tick_loc   = SrcSpan
pos
        , tick_path :: [String]
tick_path  = [String]
decl_path
        , tick_ids :: [OccName]
tick_ids   = (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
        , tick_label :: BoxLabel
tick_label = BoxLabel
boxLabel
        }

      cc_name :: FastString
cc_name | Bool
topOnly   = String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
decl_path
              | Bool
otherwise = String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"." [String]
decl_path)

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

    TickishType
ProfNotes -> do
      flavour <- CostCentreIndex -> CCFlavour
mkHpcCCFlavour (CostCentreIndex -> CCFlavour)
-> TM CostCentreIndex -> TM CCFlavour
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> TM CostCentreIndex
getCCIndexM FastString
cc_name
      let cc = FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
cc_name (TickTransEnv -> Module
this_mod TickTransEnv
env) SrcSpan
pos CCFlavour
flavour
          count = Bool
countEntries Bool -> Bool -> Bool
&& TickTransEnv -> Bool
tte_countEntries TickTransEnv
env
      return $ ProfNote cc count True{-scopes-}

    TickishType
Breakpoints -> do
      i <- Tick -> TM Int
addMixEntry Tick
me
      pure (Breakpoint noExtField i ids (this_mod env))

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

    TickishType
_otherwise -> String -> TM CoreTickish
forall a. HasCallStack => String -> a
panic String
"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
  env <- TM TickTransEnv
getEnv
  case tickishType env of
    TickishType
HpcTicks -> do e <- (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TM (HsExpr GhcTc) -> TM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
pos)) TM (HsExpr GhcTc)
m
                   ifGoodTickSrcSpan pos
                     (mkBinTickBoxHpc boxLabel pos e)
                     (return e)
    TickishType
_other   -> BoxLabel
-> Bool
-> Bool
-> SrcSpan
-> TM (HsExpr GhcTc)
-> TM (LHsExpr GhcTc)
allocTickBox (Bool -> BoxLabel
ExpBox Bool
False) Bool
False Bool
False SrcSpan
pos TM (HsExpr GhcTc)
m

mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
                -> TM (LHsExpr GhcTc)
mkBinTickBoxHpc :: (Bool -> BoxLabel)
-> SrcSpan -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
mkBinTickBoxHpc Bool -> BoxLabel
boxLabel SrcSpan
pos LHsExpr GhcTc
e = do
  env <- TM TickTransEnv
getEnv
  binTick <- HsBinTick
    <$> addMixEntry (Tick { tick_loc = pos
                          , tick_path = declPath env
                          , tick_ids = []
                          , tick_label = boxLabel True
                          })
    <*> addMixEntry (Tick { tick_loc = pos
                          , tick_path = declPath env
                          , tick_ids = []
                          , tick_label = boxLabel False
                          })
    <*> pure e
  tick <- HpcTick (this_mod env)
    <$> addMixEntry (Tick { tick_loc = pos
                          , tick_path = declPath env
                          , tick_ids = []
                          , tick_label = ExpBox False
                          })
  let pos' = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
pos
  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))

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

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