Coverage.hs 48.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4 5
{-
(c) Galois, 2006
(c) University of Glasgow, 2007
-}

Simon Marlow's avatar
Simon Marlow committed
6
{-# LANGUAGE CPP, NondecreasingIndentation #-}
7

8
module Coverage (addTicksToBinds, hpcInitCode) where
andy@galois.com's avatar
andy@galois.com committed
9

10
import Type
andy@galois.com's avatar
andy@galois.com committed
11 12 13
import HsSyn
import Module
import Outputable
14
import DynFlags
15
import Control.Monad
andy@galois.com's avatar
andy@galois.com committed
16
import SrcLoc
17
import ErrUtils
18
import NameSet hiding (FreeVars)
andy@galois.com's avatar
andy@galois.com committed
19 20
import Name
import Bag
21 22
import CostCentre
import CoreSyn
23
import Id
24
import VarSet
25 26
import Data.List
import FastString
27
import HscTypes
28
import TyCon
29
import UniqSupply
30
import BasicTypes
31
import MonadUtils
32
import Maybes
33 34
import CLabel
import Util
andy@galois.com's avatar
andy@galois.com committed
35

36
import Data.Array
37 38
import Data.Time
import System.Directory
39

40 41 42
import Trace.Hpc.Mix
import Trace.Hpc.Util

43
import BreakArray
44 45
import Data.Map (Map)
import qualified Data.Map as Map
andy@galois.com's avatar
andy@galois.com committed
46

Austin Seipp's avatar
Austin Seipp committed
47 48 49 50 51 52 53
{-
************************************************************************
*                                                                      *
*              The main function: addTicksToBinds
*                                                                      *
************************************************************************
-}
54

55
addTicksToBinds
56 57
        :: DynFlags
        -> Module
58 59 60 61 62
        -> ModLocation          -- ... off the current module
        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
                                -- isExportedId doesn't work yet (the desugarer
                                -- hasn't set it), so we have to work from this set.
        -> [TyCon]              -- Type constructor in this module
63
        -> LHsBinds Id
64
        -> IO (LHsBinds Id, HpcInfo, ModBreaks)
65

66 67 68
addTicksToBinds dflags mod mod_loc exports tyCons binds
  | let passes = coveragePasses dflags, not (null passes),
    Just orig_file <- ml_hs_file mod_loc = do
69

70 71 72
     if "boot" `isSuffixOf` orig_file
         then return (binds, emptyHpcInfo False, emptyModBreaks)
         else do
73

74
     us <- mkSplitUniqSupply 'C' -- for cost centres
75
     let  orig_file2 = guessSourceFile binds orig_file
andy@galois.com's avatar
andy@galois.com committed
76

77 78
          tickPass tickish (binds,st) =
            let env = TTE
79
                      { fileName     = mkFastString orig_file2
80
                      , declPath     = []
81
                      , tte_dflags   = dflags
82
                      , exports      = exports
83
                      , inlines      = emptyVarSet
84
                      , inScope      = emptyVarSet
85 86 87
                      , blackList    = Map.fromList
                                          [ (getSrcSpan (tyConName tyCon),())
                                          | tyCon <- tyCons ]
88
                      , density      = mkDensity tickish dflags
89
                      , this_mod     = mod
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
                      , tickishType  = tickish
                      }
                (binds',_,st') = unTM (addTickLHsBinds binds) env st
            in (binds', st')

          initState = TT { tickBoxCount = 0
                         , mixEntries   = []
                         , breakCount   = 0
                         , breaks       = []
                         , uniqSupply   = us
                         }

          (binds1,st) = foldr tickPass (binds, initState) passes

     let tickCount = tickBoxCount st
     hashNo <- writeMixEntries dflags mod tickCount (reverse $ mixEntries st)
                               orig_file2
     modBreaks <- mkModBreaks dflags (breakCount st) (reverse $ breaks st)
andy@galois.com's avatar
andy@galois.com committed
108

109
     when (dopt Opt_D_dump_ticked dflags) $
Ian Lynagh's avatar
Ian Lynagh committed
110
         log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
111
             (pprLHsBinds binds1)
112

113
     return (binds1, HpcInfo tickCount hashNo, modBreaks)
andy@galois.com's avatar
andy@galois.com committed
114

115
  | otherwise = return (binds, emptyHpcInfo False, emptyModBreaks)
116 117 118 119 120

guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
guessSourceFile binds orig_file =
     -- Try look for a file generated from a .hsc file to a
     -- .hs file, by peeking ahead.
121
     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
122 123 124 125 126 127 128 129
                                 srcSpanFileName_maybe pos : rest) [] binds
     in
     case top_pos of
        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
                      -> unpackFS file_name
        _ -> orig_file


130 131 132
mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks dflags count entries = do
  breakArray <- newBreakArray dflags $ length entries
133 134 135 136
  let
         locsTicks = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
         varsTicks = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
         declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
137 138 139
         modBreaks = emptyModBreaks
                     { modBreaks_flags = breakArray
                     , modBreaks_locs  = locsTicks
140 141
                     , modBreaks_vars  = varsTicks
                     , modBreaks_decls = declsTicks
142
                     }
143 144 145 146 147 148
  --
  return modBreaks


writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries dflags mod count entries filename
ian@well-typed.com's avatar
ian@well-typed.com committed
149
  | not (gopt Opt_Hpc dflags) = return 0
150 151 152 153 154 155
  | otherwise   = do
        let
            hpc_dir = hpcDir dflags
            mod_name = moduleNameString (moduleName mod)

            hpc_mod_dir
156 157
              | moduleUnitId mod == mainUnitId  = hpc_dir
              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
158

159 160 161
            tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.

        createDirectoryIfMissing True hpc_mod_dir
162
        modTime <- getModificationUTCTime filename
163
        let entries' = [ (hpcPos, box)
164 165 166 167
                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
        when (length entries' /= count) $ do
          panic "the number of .mix entries are inconsistent"
        let hashNo = mixHash filename modTime tabStop entries'
168
        mixCreate hpc_mod_dir mod_name
169 170 171 172 173 174 175 176 177 178 179 180 181
                       $ Mix filename modTime (toHash hashNo) tabStop entries'
        return hashNo


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

data TickDensity
  = TickForCoverage       -- for Hpc
  | TickForBreakPoints    -- for GHCi
  | TickAllFunctions      -- for -prof-auto-all
  | TickTopFunctions      -- for -prof-auto-top
  | TickExportedFunctions -- for -prof-auto-exported
182
  | TickCallSites         -- for stack tracing
183 184
  deriving Eq

185 186 187 188 189 190 191 192 193 194 195 196
mkDensity :: TickishType -> DynFlags -> TickDensity
mkDensity tickish dflags = case tickish of
  HpcTicks             -> TickForCoverage
  SourceNotes          -> TickForCoverage
  Breakpoints          -> TickForBreakPoints
  ProfNotes ->
    case profAuto dflags of
      ProfAutoAll      -> TickAllFunctions
      ProfAutoTop      -> TickTopFunctions
      ProfAutoExports  -> TickExportedFunctions
      ProfAutoCalls    -> TickCallSites
      _other           -> panic "mkDensity"
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214

-- | 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 density top_lev exported simple_pat inline
 = case density of
      TickForBreakPoints    -> not simple_pat
        -- we never add breakpoints to simple pattern bindings
        -- (there's always a tick on the rhs anyway).
      TickAllFunctions      -> not inline
      TickTopFunctions      -> top_lev && not inline
      TickExportedFunctions -> exported && not inline
      TickForCoverage       -> True
215
      TickCallSites         -> False
216 217 218 219 220 221 222 223 224

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

-- -----------------------------------------------------------------------------
-- Adding ticks to bindings
andy@galois.com's avatar
andy@galois.com committed
229 230

addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
231
addTickLHsBinds = mapBagM addTickLHsBind
andy@galois.com's avatar
andy@galois.com committed
232 233

addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
234 235 236
addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                                       abs_exports = abs_exports })) = do
  withEnv add_exports $ do
237
  withEnv add_inlines $ do
238 239
  binds' <- addTickLHsBinds binds
  return $ L pos $ bind { abs_binds = binds' }
240 241 242 243 244 245 246
 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 env =
247
     env{ exports = exports env `extendNameSetList`
248 249 250 251
                      [ idName mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , idName pid `elemNameSet` (exports env) ] }

252 253 254 255 256 257 258
   add_inlines env =
     env{ inlines = inlines env `extendVarSetList`
                      [ mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , isAnyInlinePragma (idInlinePragma pid) ] }


259
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
andy@galois.com's avatar
andy@galois.com committed
260 261
  let name = getOccString id
  decl_path <- getPathEntry
262 263 264 265 266 267 268
  density <- getDensity

  inline_ids <- liftM inlines getEnv
  let inline   = isAnyInlinePragma (idInlinePragma id)
                 || id `elemVarSet` inline_ids

  -- See Note [inline sccs]
269 270
  tickish <- tickishType `liftM` getEnv
  if inline && tickish == ProfNotes then return (L pos funBind) else do
andy@galois.com's avatar
andy@galois.com committed
271

272
  (fvs, mg@(MG { mg_alts = matches' })) <-
273
        getFreeVars $
274
        addPathEntry name $
275
        addTickMatchGroup False (fun_matches funBind)
276

277
  blackListed <- isBlackListed pos
278
  exported_names <- liftM exports getEnv
279 280

  -- We don't want to generate code for blacklisted positions
281 282 283 284 285 286 287 288 289 290 291 292 293
  -- We don't want redundant ticks on simple pattern bindings
  -- We don't want to tick non-exported bindings in TickExportedFunctions
  let simple = isSimplePatBind funBind
      toplev = null decl_path
      exported = idName id `elemNameSet` exported_names

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

294
  let mbCons = maybe Prelude.id (:)
295
  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
296
                           , fun_tick = tick `mbCons` fun_tick funBind }
297

298 299 300 301
   where
   -- a binding is a simple pattern binding if it is a funbind with zero patterns
   isSimplePatBind :: HsBind a -> Bool
   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
andy@galois.com's avatar
andy@galois.com committed
302 303

-- TODO: Revisit this
304
addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
andy@galois.com's avatar
andy@galois.com committed
305
  let name = "(...)"
306
  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
307
  let pat' = pat { pat_rhs = rhs'}
308

309
  -- Should create ticks here?
310
  density <- getDensity
andy@galois.com's avatar
andy@galois.com committed
311
  decl_path <- getPathEntry
312
  let top_lev = null decl_path
313
  if not (shouldTickPatBind density top_lev) then return (L pos pat') else do
314

315 316 317 318
    -- Allocate the ticks
    rhs_tick <- bindTick density name pos fvs
    let patvars = map getOccString (collectPatBinders lhs)
    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
319

320 321 322 323 324 325
    -- Add to pattern
    let mbCons = maybe id (:)
        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
        patvar_tickss = zipWith mbCons patvar_ticks
                        (snd (pat_ticks pat') ++ repeat [])
    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
andy@galois.com's avatar
andy@galois.com committed
326

327 328
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
cactus's avatar
cactus committed
329
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
andy@galois.com's avatar
andy@galois.com committed
330

331 332 333 334 335 336 337 338 339 340 341 342 343 344

bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
bindTick density name pos fvs = do
  decl_path <- getPathEntry
  let
      toplev        = null decl_path
      count_entries = toplev || density == TickAllFunctions
      top_only      = density /= TickAllFunctions
      box_label     = if toplev then TopLevelBox [name]
                                else LocalBox (decl_path ++ [name])
  --
  allocATickBox box_label count_entries top_only pos fvs


345 346 347 348 349 350 351 352 353 354 355 356 357 358 359
-- Note [inline sccs]
--
-- It should be reasonable to add ticks to INLINE functions; however
-- currently this tickles a bug later on because the SCCfinal pass
-- does not look inside unfoldings to find CostCentres.  It would be
-- difficult to fix that, because SCCfinal currently works on STG and
-- not Core (and since it also generates CostCentres for CAFs,
-- changing this would be difficult too).
--
-- Another reason not to add ticks to INLINE functions is that this
-- 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.

360 361 362 363 364
-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
365
addTickLHsExpr e@(L pos e0) = do
366 367
  d <- getDensity
  case d of
368
    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
369
    TickForCoverage    -> tick_it
370
    TickCallSites      | isCallSite e0      -> tick_it
371 372 373
    _other             -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
374 375 376 377 378 379 380 381
   dont_tick_it = addTickLHsExprNever 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 Id -> TM (LHsExpr Id)
addTickLHsExprRHS e@(L pos e0) = do
382 383
  d <- getDensity
  case d of
384 385
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
386
     TickForCoverage -> tick_it
387
     TickCallSites   | isCallSite e0 -> tick_it
388 389 390
     _other          -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408
   dont_tick_it = addTickLHsExprNever 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 Id -> TM (LHsExpr Id)
addTickLHsExprEvalInner e = do
   d <- getDensity
   case d of
     TickForCoverage -> addTickLHsExprNever e
     _otherwise      -> addTickLHsExpr 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.
409
addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
410 411 412 413 414 415 416 417 418
addTickLHsExprLetBody e@(L pos e0) = do
  d <- getDensity
  case d of
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
     _other -> addTickLHsExprEvalInner e
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
   dont_tick_it = addTickLHsExprNever e
419

420
-- version of addTick that does not actually add a tick,
421
-- because the scope of this tick is completely subsumed by
422 423 424 425 426 427
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

428 429 430 431 432 433
-- general heuristic: expressions which do not denote values are good break points
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {})     = True
isGoodBreakExpr (OpApp {})     = True
isGoodBreakExpr (NegApp {})    = True
isGoodBreakExpr (HsIf {})      = True
434
isGoodBreakExpr (HsMultiIf {}) = True
435
isGoodBreakExpr (HsCase {})    = True
436 437 438 439
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {})  = True
isGoodBreakExpr (PArrSeq {})   = True
440
isGoodBreakExpr _other         = False
441

442 443 444 445 446
isCallSite :: HsExpr Id -> Bool
isCallSite HsApp{}  = True
isCallSite OpApp{}  = True
isCallSite _ = False

andy@galois.com's avatar
andy@galois.com committed
447
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
448
addTickLHsExprOptAlt oneOfMany (L pos e0)
449 450 451
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))
andy@galois.com's avatar
andy@galois.com committed
452 453

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
454 455 456 457 458 459 460 461
addBinTickLHsExpr boxLabel (L pos e0)
  = ifDensity TickForCoverage
        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))


-- -----------------------------------------------------------------------------
-- Decoarate an HsExpr with ticks
andy@galois.com's avatar
andy@galois.com committed
462 463

addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
464 465 466 467
addTickHsExpr e@(HsVar id)       = do freeVar id; return e
addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsIPVar _)      = return e
addTickHsExpr e@(HsOverLit _)    = return e
Adam Gundry's avatar
Adam Gundry committed
468
addTickHsExpr e@(HsOverLabel _)  = return e
469 470 471 472 473
addTickHsExpr e@(HsLit _)        = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)

474 475 476 477 478
addTickHsExpr (OpApp e1 e2 fix e3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsExprNever e2)
                (return fix)
479
                (addTickLHsExpr e3)
480
addTickHsExpr (NegApp e neg) =
481 482 483
        liftM2 NegApp
                (addTickLHsExpr e)
                (addTickSyntaxExpr hpcSrcSpan neg)
484
addTickHsExpr (HsPar e) =
485 486
        liftM HsPar (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL e1 e2) =
487 488
        liftM2 SectionL
                (addTickLHsExpr e1)
489
                (addTickLHsExprNever e2)
490 491
addTickHsExpr (SectionR e1 e2) =
        liftM2 SectionR
492
                (addTickLHsExprNever e1)
493
                (addTickLHsExpr e2)
494 495 496 497
addTickHsExpr (ExplicitTuple es boxity) =
        liftM2 ExplicitTuple
                (mapM addTickTupArg es)
                (return boxity)
498 499
addTickHsExpr (HsCase e mgs) =
        liftM2 HsCase
500 501
                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                   -- be evaluated.
502
                (addTickMatchGroup False mgs)
503 504 505 506 507
addTickHsExpr (HsIf cnd e1 e2 e3) =
        liftM3 (HsIf cnd)
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsExprOptAlt True e2)
                (addTickLHsExprOptAlt True e3)
508 509 510 511
addTickHsExpr (HsMultiIf ty alts)
  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
       ; return $ HsMultiIf ty alts' }
512
addTickHsExpr (HsLet (L l binds) e) =
513
        bindLocals (collectLocalBinders binds) $
514 515 516 517
          liftM2 (HsLet . L l)
                  (addTickHsLocalBinds binds) -- to think about: !patterns.
                  (addTickLHsExprLetBody e)
addTickHsExpr (HsDo cxt (L l stmts) srcloc)
518
  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
519
       ; return (HsDo cxt (L l stmts') srcloc) }
andy@galois.com's avatar
andy@galois.com committed
520
  where
521 522 523
        forQual = case cxt of
                    ListComp -> Just $ BinBox QualBinBox
                    _        -> Nothing
524 525
addTickHsExpr (ExplicitList ty wit es) =
        liftM3 ExplicitList
526
                (return ty)
527
                (addTickWit wit)
Austin Seipp's avatar
Austin Seipp committed
528
                (mapM (addTickLHsExpr) es)
529 530 531
             where addTickWit Nothing = return Nothing
                   addTickWit (Just fln) = do fln' <- addTickHsExpr fln
                                              return (Just fln')
532
addTickHsExpr (ExplicitPArr ty es) =
533 534 535
        liftM2 ExplicitPArr
                (return ty)
                (mapM (addTickLHsExpr) es)
536 537 538

addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e

539 540 541 542 543 544 545 546
addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
  = do { rec_binds' <- addTickHsRecordBinds rec_binds
       ; return (expr { rcon_flds = rec_binds' }) }

addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
  = do { e' <- addTickLHsExpr e
       ; flds' <- mapM addTickHsRecField flds
       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
547

andy@galois.com's avatar
andy@galois.com committed
548
addTickHsExpr (ExprWithTySigOut e ty) =
549 550 551 552
        liftM2 ExprWithTySigOut
                (addTickLHsExprNever e) -- No need to tick the inner expression
                                    -- for expressions with signatures
                (return ty)
553 554
addTickHsExpr (ArithSeq  ty wit arith_seq) =
        liftM3 ArithSeq
555
                (return ty)
556
                (addTickWit wit)
557
                (addTickArithSeqInfo arith_seq)
558 559 560
             where addTickWit Nothing = return Nothing
                   addTickWit (Just fl) = do fl' <- addTickHsExpr fl
                                             return (Just fl')
561 562 563 564 565 566 567

-- We might encounter existing ticks (multiple Coverage passes)
addTickHsExpr (HsTick t e) =
        liftM (HsTick t) (addTickLHsExprNever e)
addTickHsExpr (HsBinTick t0 t1 e) =
        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)

Alan Zimmerman's avatar
Alan Zimmerman committed
568
addTickHsExpr (HsTickPragma _ _ (L pos e0)) = do
569
    e2 <- allocTickBox (ExpBox False) False False pos $
570
                addTickHsExpr e0
571
    return $ unLoc e2
572 573 574 575
addTickHsExpr (PArrSeq   ty arith_seq) =
        liftM2 PArrSeq
                (return ty)
                (addTickArithSeqInfo arith_seq)
Alan Zimmerman's avatar
Alan Zimmerman committed
576 577 578
addTickHsExpr (HsSCC src nm e) =
        liftM3 HsSCC
                (return src)
579 580
                (return nm)
                (addTickLHsExpr e)
Alan Zimmerman's avatar
Alan Zimmerman committed
581 582 583
addTickHsExpr (HsCoreAnn src nm e) =
        liftM3 HsCoreAnn
                (return src)
584 585
                (return nm)
                (addTickLHsExpr e)
586 587 588 589
addTickHsExpr e@(HsBracket     {})   = return e
addTickHsExpr e@(HsTcBracketOut  {}) = return e
addTickHsExpr e@(HsRnBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {})      = return e
andy@galois.com's avatar
andy@galois.com committed
590
addTickHsExpr (HsProc pat cmdtop) =
591 592 593 594 595 596 597
        liftM2 HsProc
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
addTickHsExpr (HsWrap w e) =
        liftM2 HsWrap
                (return w)
                (addTickHsExpr e)       -- explicitly no tick on inside
598

599
addTickHsExpr e@(HsType _) = return e
600

601
-- Others dhould never happen in expression content.
602
addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
andy@galois.com's avatar
andy@galois.com committed
603

604 605 606 607
addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
                                      ; return (L l (Present e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
608

609
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
610
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
611
  let isOneOfMany = matchesOneOfMany matches
612
  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
613
  return $ mg { mg_alts = L l matches' }
andy@galois.com's avatar
andy@galois.com committed
614

615
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
Alan Zimmerman's avatar
Alan Zimmerman committed
616
addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
617
  bindLocals (collectPatsBinders pats) $ do
618
    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
Alan Zimmerman's avatar
Alan Zimmerman committed
619
    return $ Match mf pats opSig gRHSs'
andy@galois.com's avatar
andy@galois.com committed
620

621
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
622
addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
623
  bindLocals binders $ do
624
    local_binds' <- addTickHsLocalBinds local_binds
625
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
626
    return $ GRHSs guarded' (L l local_binds')
627
  where
628
    binders = collectLocalBinders local_binds
andy@galois.com's avatar
andy@galois.com committed
629

630
addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
631
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
632
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
633
                        (addTickGRHSBody isOneOfMany isLambda expr)
andy@galois.com's avatar
andy@galois.com committed
634 635
  return $ GRHS stmts' expr'

636 637 638 639 640 641 642 643 644 645
addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)
addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
  d <- getDensity
  case d of
    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
    TickAllFunctions | isLambda ->
       addPathEntry "\\" $
         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
           addTickHsExpr e0
    _otherwise ->
646
       addTickLHsExprRHS expr
647

648
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
649
addTickLStmts isGuard stmts = do
650 651 652
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

653 654
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
               -> TM ([ExprLStmt Id], a)
655
addTickLStmts' isGuard lstmts res
656
  = bindLocals (collectLStmtsBinders lstmts) $
657 658 659
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
660

661
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
Simon Marlow's avatar
Simon Marlow committed
662 663
addTickStmt _isGuard (LastStmt e noret ret) = do
        liftM3 LastStmt
664
                (addTickLHsExpr e)
Simon Marlow's avatar
Simon Marlow committed
665
                (pure noret)
666
                (addTickSyntaxExpr hpcSrcSpan ret)
667
addTickStmt _isGuard (BindStmt pat e bind fail) = do
668 669 670 671 672
        liftM4 BindStmt
                (addTickLPat pat)
                (addTickLHsExprRHS e)
                (addTickSyntaxExpr hpcSrcSpan bind)
                (addTickSyntaxExpr hpcSrcSpan fail)
673 674
addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
        liftM4 BodyStmt
675 676 677 678
                (addTick isGuard e)
                (addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
                (return ty)
679 680
addTickStmt _isGuard (LetStmt (L l binds)) = do
        liftM (LetStmt . L l)
681
                (addTickHsLocalBinds binds)
682
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
683
    liftM3 ParStmt
684
        (mapM (addTickStmtAndBinders isGuard) pairs)
685 686
        (addTickSyntaxExpr hpcSrcSpan mzipExpr)
        (addTickSyntaxExpr hpcSrcSpan bindExpr)
Simon Marlow's avatar
Simon Marlow committed
687 688 689
addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
    args' <- mapM (addTickApplicativeArg isGuard) args
    return (ApplicativeStmt args' mb_join body_ty)
690

691 692 693 694
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
695
    t_s <- addTickLStmts isGuard stmts
696 697
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
698 699 700
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
701 702
    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 }
703

704 705 706 707 708 709
addTickStmt isGuard stmt@(RecStmt {})
  = do { stmts' <- addTickLStmts isGuard (recS_stmts 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 = stmts', recS_ret_fn = ret'
710
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
711

712
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
713
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
714
                  | otherwise          = addTickLHsExprRHS e
715

Simon Marlow's avatar
Simon Marlow committed
716 717 718 719 720 721 722 723 724 725 726 727 728 729
addTickApplicativeArg
  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id)
  -> TM (SyntaxExpr Id, ApplicativeArg Id Id)
addTickApplicativeArg isGuard (op, arg) =
  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
 where
  addTickArg (ApplicativeArgOne pat expr) =
    ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr
  addTickArg (ApplicativeArgMany stmts ret pat) =
    ApplicativeArgMany
      <$> addTickLStmts isGuard stmts
      <*> addTickSyntaxExpr hpcSrcSpan ret
      <*> addTickLPat pat

730 731
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
                      -> TM (ParStmtBlock Id Id)
732 733
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
    liftM3 ParStmtBlock
734 735
        (addTickLStmts isGuard stmts)
        (return ids)
736
        (addTickSyntaxExpr hpcSrcSpan returnExpr)
737

andy@galois.com's avatar
andy@galois.com committed
738
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
739 740 741 742 743 744
addTickHsLocalBinds (HsValBinds binds) =
        liftM HsValBinds
                (addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  =
        liftM HsIPBinds
                (addTickHsIPBinds binds)
andy@galois.com's avatar
andy@galois.com committed
745 746
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

747
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
andy@galois.com's avatar
andy@galois.com committed
748
addTickHsValBinds (ValBindsOut binds sigs) =
749 750 751 752 753 754 755
        liftM2 ValBindsOut
                (mapM (\ (rec,binds') ->
                                liftM2 (,)
                                        (return rec)
                                        (addTickLHsBinds binds'))
                        binds)
                (return sigs)
756
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
757

758
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
andy@galois.com's avatar
andy@galois.com committed
759
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
760 761 762
        liftM2 IPBinds
                (mapM (liftL (addTickIPBind)) ipbinds)
                (return dictbinds)
andy@galois.com's avatar
andy@galois.com committed
763 764 765

addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind (IPBind nm e) =
766 767 768
        liftM2 IPBind
                (return nm)
                (addTickLHsExpr e)
andy@galois.com's avatar
andy@galois.com committed
769 770 771 772

-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
addTickSyntaxExpr pos x = do
773 774
        L _ x' <- addTickLHsExpr (L pos x)
        return $ x'
andy@galois.com's avatar
andy@galois.com committed
775 776 777 778 779 780
-- we do not walk into patterns.
addTickLPat :: LPat Id -> TM (LPat Id)
addTickLPat pat = return pat

addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
781 782 783 784 785
        liftM4 HsCmdTop
                (addTickLHsCmd cmd)
                (return tys)
                (return ty)
                (return syntaxtable)
andy@galois.com's avatar
andy@galois.com committed
786

787
addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
788 789
addTickLHsCmd (L pos c0) = do
        c1 <- addTickHsCmd c0
790
        return $ L pos c1
791 792

addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
793 794 795 796 797
addTickHsCmd (HsCmdLam matchgroup) =
        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp c e) =
        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
798 799 800 801 802 803
addTickHsCmd (OpApp e1 c2 fix c3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsCmd c2)
                (return fix)
                (addTickLHsCmd c3)
804 805 806 807
-}
addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
addTickHsCmd (HsCmdCase e mgs) =
        liftM2 HsCmdCase
808 809
                (addTickLHsExpr e)
                (addTickCmdMatchGroup mgs)
810 811
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
        liftM3 (HsCmdIf cnd)
812 813 814
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsCmd c2)
                (addTickLHsCmd c3)
815
addTickHsCmd (HsCmdLet (L l binds) c) =
816
        bindLocals (collectLocalBinders binds) $
817 818 819 820
          liftM2 (HsCmdLet . L l)
                   (addTickHsLocalBinds binds) -- to think about: !patterns.
                   (addTickLHsCmd c)
addTickHsCmd (HsCmdDo (L l stmts) srcloc)
821
  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
822
       ; return (HsCmdDo (L l stmts') srcloc) }
823

824 825
addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =
        liftM5 HsCmdArrApp
826 827 828 829 830
               (addTickLHsExpr e1)
               (addTickLHsExpr e2)
               (return ty1)
               (return arr_ty)
               (return lr)
831 832
addTickHsCmd (HsCmdArrForm e fix cmdtop) =
        liftM3 HsCmdArrForm
833 834 835
               (addTickLHsExpr e)
               (return fix)
               (mapM (liftL (addTickHsCmdTop)) cmdtop)
836

Austin Seipp's avatar
Austin Seipp committed
837
addTickHsCmd (HsCmdCast co cmd)
838 839
  = liftM2 HsCmdCast (return co) (addTickHsCmd cmd)

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

843
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
844
addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
845
  matches' <- mapM (liftL addTickCmdMatch) matches
846
  return $ mg { mg_alts = L l matches' }
847

848
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
Alan Zimmerman's avatar
Alan Zimmerman committed
849
addTickCmdMatch (Match mf pats opSig gRHSs) =
850 851
  bindLocals (collectPatsBinders pats) $ do
    gRHSs' <- addTickCmdGRHSs gRHSs
Alan Zimmerman's avatar
Alan Zimmerman committed
852
    return $ Match mf pats opSig gRHSs'
853

854
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
855
addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
856 857 858
  bindLocals binders $ do
    local_binds' <- addTickHsLocalBinds local_binds
    guarded' <- mapM (liftL addTickCmdGRHS) guarded
859
    return $ GRHSs guarded' (L l local_binds')
860 861 862
  where
    binders = collectLocalBinders local_binds

863
addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
864 865 866
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
867
  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
868 869
                                   stmts (addTickLHsCmd cmd)
       ; return $ GRHS stmts' expr' }
870

871
addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
872 873 874 875
addTickLCmdStmts stmts = do
  (stmts, _) <- addTickLCmdStmts' stmts (return ())
  return stmts

876
addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)
877 878 879 880 881 882 883 884
addTickLCmdStmts' lstmts res
  = bindLocals binders $ do
        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
        a <- res
        return (lstmts', a)
  where
        binders = collectLStmtsBinders lstmts

885
addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
886
addTickCmdStmt (BindStmt pat c bind fail) = do
887 888 889 890 891
        liftM4 BindStmt
                (addTickLPat pat)
                (addTickLHsCmd c)
                (return bind)
                (return fail)
Simon Marlow's avatar
Simon Marlow committed
892 893
addTickCmdStmt (LastStmt c noret ret) = do
        liftM3 LastStmt
894
                (addTickLHsCmd c)
Simon Marlow's avatar
Simon Marlow committed
895
                (pure noret)
896
                (addTickSyntaxExpr hpcSrcSpan ret)
897 898
addTickCmdStmt (BodyStmt c bind' guard' ty) = do
        liftM4 BodyStmt
899 900
                (addTickLHsCmd c)
                (addTickSyntaxExpr hpcSrcSpan bind')
901
                (addTickSyntaxExpr hpcSrcSpan guard')
902
                (return ty)
903 904
addTickCmdStmt (LetStmt (L l binds)) = do
        liftM (LetStmt . L l)
905
                (addTickHsLocalBinds binds)
906 907 908 909 910 911 912
addTickCmdStmt stmt@(RecStmt {})
  = do { stmts' <- addTickLCmdStmts (recS_stmts 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 = stmts', recS_ret_fn = ret'
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
Simon Marlow's avatar
Simon Marlow committed
913 914
addTickCmdStmt ApplicativeStmt{} =
  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
915 916 917

-- Others should never happen in a command context.
addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
andy@galois.com's avatar
andy@galois.com committed
918 919

addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
920
addTickHsRecordBinds (HsRecFields fields dd)
921
  = do  { fields' <- mapM addTickHsRecField fields
922
        ; return (HsRecFields fields' dd) }
923 924 925

addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id))
addTickHsRecField (L l (HsRecField id expr pun))
926
        = do { expr' <- addTickLHsExpr expr
927 928
             ; return (L l (HsRecField id expr' pun)) }

andy@galois.com's avatar
andy@galois.com committed
929 930 931

addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
932 933
        liftM From
                (addTickLHsExpr e1)
andy@galois.com's avatar
andy@galois.com committed
934
addTickArithSeqInfo (FromThen e1 e2) =
935 936 937
        liftM2 FromThen
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
andy@galois.com's avatar
andy@galois.com committed
938
addTickArithSeqInfo (FromTo e1 e2) =
939 940 941
        liftM2 FromTo
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
andy@galois.com's avatar
andy@galois.com committed
942
addTickArithSeqInfo (FromThenTo e1 e2 e3) =
943 944 945 946
        liftM3 FromThenTo
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
                (addTickLHsExpr e3)
947 948 949 950 951

liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
liftL f (L loc a) = do
  a' <- f a
  return $ L loc a'
andy@galois.com's avatar
andy@galois.com committed
952

953
data TickTransState = TT { tickBoxCount:: Int
954
                         , mixEntries  :: [MixEntry_]
955 956 957
                         , breakCount  :: Int
                         , breaks      :: [MixEntry_]
                         , uniqSupply  :: UniqSupply
958
                         }
959

960 961
data TickTransEnv = TTE { fileName     :: FastString
                        , density      :: TickDensity
962
                        , tte_dflags   :: DynFlags
963
                        , exports      :: NameSet
964
                        , inlines      :: VarSet
965
                        , declPath     :: [String]
966
                        , inScope      :: VarSet
967 968
                        , blackList    :: Map SrcSpan ()
                        , this_mod     :: Module
969
                        , tickishType  :: TickishType
970
                        }
971

972
--      deriving Show
andy@galois.com's avatar
andy@galois.com committed
973

Peter Wortmann's avatar
Peter Wortmann committed
974
data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
975 976 977 978 979 980 981 982 983 984 985
                 deriving (Eq)

coveragePasses :: DynFlags -> [TickishType]
coveragePasses dflags =
    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
    ifa (gopt Opt_Hpc dflags)                HpcTicks $
    ifa (gopt Opt_SccProfilingOn dflags &&
         profAuto dflags /= NoProfAuto)      ProfNotes $
    ifa (gopt Opt_Debug dflags)              SourceNotes []
  where ifa f x xs | f         = x:xs
                   | otherwise = xs
986 987 988 989 990 991 992 993

-- | 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 HpcTicks = True
tickSameFileOnly _other   = False

994
type FreeVars = OccEnv Id
995
noFVs :: FreeVars
996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009
noFVs = 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.

1010
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
1011 1012
        -- a combination of a state monad (TickTransState) and a writer
        -- monad (FreeVars).
andy@galois.com's avatar
andy@galois.com committed
1013

Austin Seipp's avatar
Austin Seipp committed
1014 1015 1016 1017
instance Functor TM where
    fmap = liftM

instance Applicative TM where