Coverage.lhs 40.5 KB
Newer Older
andy@galois.com's avatar
andy@galois.com committed
1 2
%
% (c) Galois, 2006
3
% (c) University of Glasgow, 2007
andy@galois.com's avatar
andy@galois.com committed
4 5
%
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
6 7 8 9 10 11 12
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

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

15
import Type
andy@galois.com's avatar
andy@galois.com committed
16 17 18
import HsSyn
import Module
import Outputable
19
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
20
import Control.Monad
andy@galois.com's avatar
andy@galois.com committed
21
import SrcLoc
22
import ErrUtils
23
import NameSet hiding (FreeVars)
andy@galois.com's avatar
andy@galois.com committed
24 25
import Name
import Bag
26 27
import CostCentre
import CoreSyn
28
import Id
29
import VarSet
30 31
import Data.List
import FastString
32
import HscTypes	
33
import Platform
34
import StaticFlags
35
import TyCon
36
import Unique
37
import BasicTypes
38
import MonadUtils
39
import Maybes
40 41
import CLabel
import Util
andy@galois.com's avatar
andy@galois.com committed
42

43
import Data.Array
andy@galois.com's avatar
andy@galois.com committed
44
import System.Directory ( createDirectoryIfMissing )
45

46 47 48
import Trace.Hpc.Mix
import Trace.Hpc.Util

49
import BreakArray 
50
import Data.HashTable   ( hashString )
51 52
import Data.Map (Map)
import qualified Data.Map as Map
andy@galois.com's avatar
andy@galois.com committed
53 54
\end{code}

55

andy@galois.com's avatar
andy@galois.com committed
56 57
%************************************************************************
%*									*
58
%*              The main function: addTicksToBinds
andy@galois.com's avatar
andy@galois.com committed
59 60 61 62
%*									*
%************************************************************************

\begin{code}
63
addTicksToBinds
64 65
        :: DynFlags
        -> Module
66 67 68 69 70
        -> 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
71
        -> LHsBinds Id
72
        -> IO (LHsBinds Id, HpcInfo, ModBreaks)
73

74
addTicksToBinds dflags mod mod_loc exports tyCons binds =
75

76 77 78
 case ml_hs_file mod_loc of
   Nothing        -> return (binds, emptyHpcInfo False, emptyModBreaks)
   Just orig_file -> do
79

80 81 82 83 84
     if "boot" `isSuffixOf` orig_file
         then return (binds, emptyHpcInfo False, emptyModBreaks)
         else do
   
     let  orig_file2 = guessSourceFile binds orig_file
andy@galois.com's avatar
andy@galois.com committed
85

86
          (binds1,_,st)
andy@galois.com's avatar
andy@galois.com committed
87
		 = unTM (addTickLHsBinds binds) 
88
		   (TTE
89
                      { fileName     = mkFastString orig_file2
andy@galois.com's avatar
andy@galois.com committed
90
		      , declPath     = []
91 92
                      , dflags       = dflags
                      , exports      = exports
93
                      , inScope      = emptyVarSet
94 95 96 97 98 99
                      , blackList    = Map.fromList
                                          [ (getSrcSpan (tyConName tyCon),())
                                          | tyCon <- tyCons ]
                      , density      = mkDensity dflags
                      , this_mod     = mod
                       })
100 101
		   (TT 
		      { tickBoxCount = 0
andy@galois.com's avatar
andy@galois.com committed
102
		      , mixEntries   = []
103
		      })
andy@galois.com's avatar
andy@galois.com committed
104

105
     let entries = reverse $ mixEntries st
106

107 108 109
     let count = tickBoxCount st
     hashNo <- writeMixEntries dflags mod count entries orig_file2
     modBreaks <- mkModBreaks count entries
andy@galois.com's avatar
andy@galois.com committed
110

111 112 113
     doIfSet_dyn dflags Opt_D_dump_ticked $ printDump (pprLHsBinds binds1)
   
     return (binds1, HpcInfo count hashNo, modBreaks)
andy@galois.com's avatar
andy@galois.com committed
114

115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180

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.
     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
                                 srcSpanFileName_maybe pos : rest) [] binds
     in
     case top_pos of
        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
                      -> unpackFS file_name
        _ -> orig_file


mkModBreaks :: Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks count entries = do
  breakArray <- newBreakArray $ length entries
  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 ]
         modBreaks = emptyModBreaks 
                     { modBreaks_flags = breakArray 
                     , modBreaks_locs  = locsTicks 
                     , modBreaks_vars  = varsTicks
                     , modBreaks_decls = declsTicks
                     } 
  --
  return modBreaks


writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries dflags mod count entries filename
  | not opt_Hpc = return 0
  | otherwise   = do
        let
            hpc_dir = hpcDir dflags
            mod_name = moduleNameString (moduleName mod)

            hpc_mod_dir
              | modulePackageId mod == mainPackageId  = hpc_dir
              | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
   
            tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.

        createDirectoryIfMissing True hpc_mod_dir
        modTime <- getModificationTime filename
        let entries' = [ (hpcPos, box) 
                       | (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'
        mixCreate hpc_mod_dir mod_name 
                       $ 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
181
  | TickCallSites         -- for stack tracing
182 183 184 185 186 187 188 189 190
  deriving Eq

mkDensity :: DynFlags -> TickDensity
mkDensity dflags
  | opt_Hpc                              = TickForCoverage
  | HscInterpreted  <- hscTarget dflags  = TickForBreakPoints
  | ProfAutoAll     <- profAuto dflags   = TickAllFunctions
  | ProfAutoTop     <- profAuto dflags   = TickTopFunctions
  | ProfAutoExports <- profAuto dflags   = TickExportedFunctions
191
  | ProfAutoCalls   <- profAuto dflags   = TickCallSites
192
  | otherwise = panic "desnity"
193 194 195 196 197
  -- ToDo: -fhpc is taking priority over -fprof-auto here.  It seems
  -- that coverage works perfectly well with profiling, but you don't
  -- get any auto-generated SCCs.  It would make perfect sense to
  -- allow both of them, and indeed to combine some of the other flags
  -- (-fprof-auto-calls -fprof-auto-top, for example)
198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215

-- | 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
216
      TickCallSites         -> False
217 218 219 220 221 222 223 224 225

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

-- -----------------------------------------------------------------------------
-- Adding ticks to bindings
andy@galois.com's avatar
andy@galois.com committed
230 231 232 233 234

addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds binds = mapBagM addTickLHsBind binds

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

addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
andy@galois.com's avatar
andy@galois.com committed
253 254 255
  let name = getOccString id
  decl_path <- getPathEntry

256
  (fvs, (MatchGroup matches' ty)) <- 
257
        getFreeVars $
258
        addPathEntry name $
259
        addTickMatchGroup False (fun_matches funBind)
260

261
  blackListed <- isBlackListed pos
262 263
  density <- getDensity
  exported_names <- liftM exports getEnv
264 265

  -- We don't want to generate code for blacklisted positions
266 267 268 269 270
  -- 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
Simon Marlow's avatar
Simon Marlow committed
271 272
      inline   = {- pprTrace "inline" (ppr id <+> ppr (idInlinePragma id)) $ -}
                 isAnyInlinePragma (idInlinePragma id)
273 274 275 276 277 278 279 280 281 282 283

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

  return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
                           , fun_tick = tick }

284 285 286 287
   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
288 289

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

  density <- getDensity
andy@galois.com's avatar
andy@galois.com committed
295
  decl_path <- getPathEntry
296 297 298 299 300 301 302 303 304 305 306 307 308 309
  let top_lev = null decl_path
  let add_ticks = shouldTickPatBind density top_lev

  tickish <- if add_ticks
                then bindTick density name pos fvs
                else return Nothing

  let patvars = map getOccString (collectPatBinders lhs)
  patvar_ticks <- if add_ticks
                     then mapM (\v -> bindTick density v pos fvs) patvars
                     else return []

  return $ L pos $ pat { pat_rhs = rhs',
                         pat_ticks = (tickish, patvar_ticks)}
andy@galois.com's avatar
andy@galois.com committed
310

311 312
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
andy@galois.com's avatar
andy@galois.com committed
313

314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332

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


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

-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
333
addTickLHsExpr e@(L pos e0) = do
334 335
  d <- getDensity
  case d of
336
    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
337
    TickForCoverage    -> tick_it
338
    TickCallSites      | isCallSite e0      -> tick_it
339 340 341
    _other             -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
342 343 344 345 346 347 348 349
   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
350 351
  d <- getDensity
  case d of
352 353
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
354
     TickForCoverage -> tick_it
355
     TickCallSites   | isCallSite e0 -> tick_it
356 357 358
     _other          -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376
   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.
377
addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
378 379 380 381 382 383 384 385 386
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
387

388 389 390 391 392 393 394 395
-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by 
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

396 397 398 399 400 401
-- 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
402
isGoodBreakExpr (HsCase {})    = True
403 404 405 406
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {})  = True
isGoodBreakExpr (PArrSeq {})   = True
407
isGoodBreakExpr _other         = False 
408

409 410 411 412 413
isCallSite :: HsExpr Id -> Bool
isCallSite HsApp{}  = True
isCallSite OpApp{}  = True
isCallSite _ = False

andy@galois.com's avatar
andy@galois.com committed
414
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
415
addTickLHsExprOptAlt oneOfMany (L pos e0)
416 417 418
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))
andy@galois.com's avatar
andy@galois.com committed
419 420

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
421 422 423 424 425 426 427 428
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
429 430

addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
431
addTickHsExpr e@(HsVar id) = do freeVar id; return e
andy@galois.com's avatar
andy@galois.com committed
432 433 434
addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsLit _) = return e
435
addTickHsExpr (HsLam matchgroup) =
436 437
        liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsApp e1 e2) =
438
	liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
andy@galois.com's avatar
andy@galois.com committed
439 440 441
addTickHsExpr (OpApp e1 e2 fix e3) = 
	liftM4 OpApp 
		(addTickLHsExpr e1) 
442
		(addTickLHsExprNever e2)
andy@galois.com's avatar
andy@galois.com committed
443
		(return fix)
444
                (addTickLHsExpr e3)
445
addTickHsExpr (NegApp e neg) =
andy@galois.com's avatar
andy@galois.com committed
446 447 448
	liftM2 NegApp
		(addTickLHsExpr e) 
		(addTickSyntaxExpr hpcSrcSpan neg)
449
addTickHsExpr (HsPar e) =
450 451
        liftM HsPar (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL e1 e2) =
andy@galois.com's avatar
andy@galois.com committed
452 453
	liftM2 SectionL
		(addTickLHsExpr e1)
454
                (addTickLHsExprNever e2)
andy@galois.com's avatar
andy@galois.com committed
455 456
addTickHsExpr (SectionR e1 e2) = 
	liftM2 SectionR
457
                (addTickLHsExprNever e1)
andy@galois.com's avatar
andy@galois.com committed
458
		(addTickLHsExpr e2)
459 460 461 462
addTickHsExpr (ExplicitTuple es boxity) =
        liftM2 ExplicitTuple
                (mapM addTickTupArg es)
                (return boxity)
andy@galois.com's avatar
andy@galois.com committed
463 464
addTickHsExpr (HsCase e mgs) = 
	liftM2 HsCase
465 466
                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                   -- be evaluated.
467
                (addTickMatchGroup False mgs)
468 469
addTickHsExpr (HsIf cnd e1 e2 e3) = 
	liftM3 (HsIf cnd)
470
		(addBinTickLHsExpr (BinBox CondBinBox) e1)
andy@galois.com's avatar
andy@galois.com committed
471 472 473
		(addTickLHsExprOptAlt True e2)
		(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
474
	bindLocals (collectLocalBinders binds) $
andy@galois.com's avatar
andy@galois.com committed
475
	liftM2 HsLet
476
		(addTickHsLocalBinds binds) -- to think about: !patterns.
477
                (addTickLHsExprLetBody e)
478 479 480
addTickHsExpr (HsDo cxt stmts srcloc) 
  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
       ; return (HsDo cxt stmts' srcloc) }
andy@galois.com's avatar
andy@galois.com committed
481 482
  where
	forQual = case cxt of
483
		    ListComp -> Just $ BinBox QualBinBox
andy@galois.com's avatar
andy@galois.com committed
484 485
		    _        -> Nothing
addTickHsExpr (ExplicitList ty es) = 
486
	liftM2 ExplicitList
andy@galois.com's avatar
andy@galois.com committed
487
		(return ty)
488
		(mapM (addTickLHsExpr) es)
489 490 491 492
addTickHsExpr (ExplicitPArr ty es) =
	liftM2 ExplicitPArr
		(return ty)
		(mapM (addTickLHsExpr) es)
493
addTickHsExpr (RecordCon id ty rec_binds) = 
andy@galois.com's avatar
andy@galois.com committed
494 495 496 497
	liftM3 RecordCon
		(return id)
		(return ty)
		(addTickHsRecordBinds rec_binds)
498 499
addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
	liftM5 RecordUpd
andy@galois.com's avatar
andy@galois.com committed
500 501
		(addTickLHsExpr e)
		(addTickHsRecordBinds rec_binds)
502 503
		(return cons) (return tys1) (return tys2)

andy@galois.com's avatar
andy@galois.com committed
504 505
addTickHsExpr (ExprWithTySigOut e ty) =
	liftM2 ExprWithTySigOut
506
		(addTickLHsExprNever e) -- No need to tick the inner expression
andy@galois.com's avatar
andy@galois.com committed
507 508 509 510 511 512
				    -- for expressions with signatures
		(return ty)
addTickHsExpr (ArithSeq	 ty arith_seq) =
	liftM2 ArithSeq	
		(return ty)
		(addTickArithSeqInfo arith_seq)
513
addTickHsExpr (HsTickPragma _ (L pos e0)) = do
514
    e2 <- allocTickBox (ExpBox False) False False pos $
515
                addTickHsExpr e0
516
    return $ unLoc e2
517 518 519 520 521 522 523 524 525 526 527 528
addTickHsExpr (PArrSeq	 ty arith_seq) =
	liftM2 PArrSeq	
		(return ty)
		(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC nm e) =
        liftM2 HsSCC 
                (return nm)
                (addTickLHsExpr e)
addTickHsExpr (HsCoreAnn nm e) = 
        liftM2 HsCoreAnn 
                (return nm)
                (addTickLHsExpr e)
andy@galois.com's avatar
andy@galois.com committed
529 530 531 532 533 534
addTickHsExpr e@(HsBracket     {}) = return e
addTickHsExpr e@(HsBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {}) = return e
addTickHsExpr (HsProc pat cmdtop) =
	liftM2 HsProc
		(addTickLPat pat)
535
		(liftL (addTickHsCmdTop) cmdtop)
andy@galois.com's avatar
andy@galois.com committed
536 537 538 539
addTickHsExpr (HsWrap w e) = 
	liftM2 HsWrap
		(return w)
		(addTickHsExpr e)	-- explicitly no tick on inside
540

541
addTickHsExpr e@(HsType _) = return e
542

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

546 547 548 549
addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)

550 551
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id)
addTickMatchGroup is_lam (MatchGroup matches ty) = do
552
  let isOneOfMany = matchesOneOfMany matches
553
  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
andy@galois.com's avatar
andy@galois.com committed
554 555
  return $ MatchGroup matches' ty

556 557
addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id)
addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
558
  bindLocals (collectPatsBinders pats) $ do
559
    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
560
    return $ Match pats opSig gRHSs'
andy@galois.com's avatar
andy@galois.com committed
561

562 563
addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id)
addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
564
  bindLocals binders $ do
565
    local_binds' <- addTickHsLocalBinds local_binds
566
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
567 568
    return $ GRHSs guarded' local_binds'
  where
569
    binders = collectLocalBinders local_binds
andy@galois.com's avatar
andy@galois.com committed
570

571 572
addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id)
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
573
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
574
                        (addTickGRHSBody isOneOfMany isLambda expr)
andy@galois.com's avatar
andy@galois.com committed
575 576
  return $ GRHS stmts' expr'

577 578 579 580 581 582 583 584 585 586
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 ->
587
       addTickLHsExprRHS expr
588

589 590
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts isGuard stmts = do
591 592 593 594 595 596
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a 
               -> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
597 598 599 600
  = bindLocals (collectLStmtsBinders lstmts) $ 
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
601 602

addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
603 604
addTickStmt _isGuard (LastStmt e ret) = do
	liftM2 LastStmt
605
		(addTickLHsExpr e)
606
		(addTickSyntaxExpr hpcSrcSpan ret)
607
addTickStmt _isGuard (BindStmt pat e bind fail) = do
608
	liftM4 BindStmt
andy@galois.com's avatar
andy@galois.com committed
609
		(addTickLPat pat)
610
		(addTickLHsExprRHS e)
andy@galois.com's avatar
andy@galois.com committed
611 612
		(addTickSyntaxExpr hpcSrcSpan bind)
		(addTickSyntaxExpr hpcSrcSpan fail)
613 614
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
	liftM4 ExprStmt
615
		(addTick isGuard e)
andy@galois.com's avatar
andy@galois.com committed
616
		(addTickSyntaxExpr hpcSrcSpan bind')
617
		(addTickSyntaxExpr hpcSrcSpan guard')
andy@galois.com's avatar
andy@galois.com committed
618
		(return ty)
619
addTickStmt _isGuard (LetStmt binds) = do
620 621
	liftM LetStmt
		(addTickHsLocalBinds binds)
622 623
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
    liftM4 ParStmt 
624
        (mapM (addTickStmtAndBinders isGuard) pairs)
625 626 627 628
        (addTickSyntaxExpr hpcSrcSpan mzipExpr)
        (addTickSyntaxExpr hpcSrcSpan bindExpr)
        (addTickSyntaxExpr hpcSrcSpan returnExpr)

629 630 631 632
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
633
    t_s <- addTickLStmts isGuard stmts
634 635
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
636 637 638
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
639 640
    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 }
641

642 643 644 645 646 647
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'
648
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
649

650
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
651
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
652
                  | otherwise          = addTickLHsExprRHS e
653

654 655
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) 
                      -> TM ([LStmt Id], a)
656 657 658 659 660
addTickStmtAndBinders isGuard (stmts, ids) = 
    liftM2 (,) 
        (addTickLStmts isGuard stmts)
        (return ids)

andy@galois.com's avatar
andy@galois.com committed
661 662 663 664 665 666 667 668 669
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) = 
	liftM HsValBinds 
		(addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  = 
	liftM HsIPBinds 
		(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

670
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
andy@galois.com's avatar
andy@galois.com committed
671 672 673 674 675 676 677 678
addTickHsValBinds (ValBindsOut binds sigs) =
	liftM2 ValBindsOut
		(mapM (\ (rec,binds') -> 
				liftM2 (,)
					(return rec)
					(addTickLHsBinds binds'))
			binds)
		(return sigs)
679
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
680

681
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
andy@galois.com's avatar
andy@galois.com committed
682 683
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
	liftM2 IPBinds
684
		(mapM (liftL (addTickIPBind)) ipbinds)
685
		(return dictbinds)
andy@galois.com's avatar
andy@galois.com committed
686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709

addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind (IPBind nm e) =
	liftM2 IPBind
		(return nm)
		(addTickLHsExpr e)

-- 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
	L _ x' <- addTickLHsExpr (L pos x)
	return $ x'
-- 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) =
	liftM4 HsCmdTop
		(addTickLHsCmd cmd)
		(return tys)
		(return ty)
		(return syntaxtable)

710
addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
711 712 713 714 715 716 717
addTickLHsCmd (L pos c0) = do
        c1 <- addTickHsCmd c0
        return $ L pos c1 

addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) =
        liftM HsLam (addTickCmdMatchGroup matchgroup)
Ross Paterson's avatar
Ross Paterson committed
718 719
addTickHsCmd (HsApp c e) = 
	liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740
addTickHsCmd (OpApp e1 c2 fix c3) = 
	liftM4 OpApp 
		(addTickLHsExpr e1) 
		(addTickLHsCmd c2)
		(return fix)
		(addTickLHsCmd c3)
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
addTickHsCmd (HsCase e mgs) = 
	liftM2 HsCase
		(addTickLHsExpr e) 
		(addTickCmdMatchGroup mgs)
addTickHsCmd (HsIf cnd e1 c2 c3) = 
	liftM3 (HsIf cnd)
		(addBinTickLHsExpr (BinBox CondBinBox) e1)
		(addTickLHsCmd c2)
		(addTickLHsCmd c3)
addTickHsCmd (HsLet binds c) =
	bindLocals (collectLocalBinders binds) $
	liftM2 HsLet
		(addTickHsLocalBinds binds) -- to think about: !patterns.
                (addTickLHsCmd c)
741 742 743
addTickHsCmd (HsDo cxt stmts srcloc)
  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
       ; return (HsDo cxt stmts' srcloc) }
744

745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
addTickHsCmd (HsArrApp	 e1 e2 ty1 arr_ty lr) = 
        liftM5 HsArrApp
	       (addTickLHsExpr e1)
	       (addTickLHsExpr e2)
	       (return ty1)
	       (return arr_ty)
	       (return lr)
addTickHsCmd (HsArrForm e fix cmdtop) = 
        liftM3 HsArrForm
	       (addTickLHsExpr e)
	       (return fix)
	       (mapM (liftL (addTickHsCmdTop)) cmdtop)

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

addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
addTickCmdMatchGroup (MatchGroup matches ty) = do
  matches' <- mapM (liftL addTickCmdMatch) matches
  return $ MatchGroup matches' ty

addTickCmdMatch :: Match Id -> TM (Match Id)
addTickCmdMatch (Match pats opSig gRHSs) =
  bindLocals (collectPatsBinders pats) $ do
    gRHSs' <- addTickCmdGRHSs gRHSs
    return $ Match pats opSig gRHSs'

addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
addTickCmdGRHSs (GRHSs guarded local_binds) = do
  bindLocals binders $ do
    local_binds' <- addTickHsLocalBinds local_binds
    guarded' <- mapM (liftL addTickCmdGRHS) guarded
    return $ GRHSs guarded' local_binds'
  where
    binders = collectLocalBinders local_binds

addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
782 783 784 785 786 787
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) 
                                   stmts (addTickLHsCmd cmd)
       ; return $ GRHS stmts' expr' }
788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809

addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
addTickLCmdStmts stmts = do
  (stmts, _) <- addTickLCmdStmts' stmts (return ())
  return stmts

addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
addTickLCmdStmts' lstmts res
  = bindLocals binders $ do
        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
        a <- res
        return (lstmts', a)
  where
        binders = collectLStmtsBinders lstmts

addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
addTickCmdStmt (BindStmt pat c bind fail) = do
	liftM4 BindStmt
		(addTickLPat pat)
		(addTickLHsCmd c)
		(return bind)
		(return fail)
810 811 812 813
addTickCmdStmt (LastStmt c ret) = do
	liftM2 LastStmt
		(addTickLHsCmd c)
		(addTickSyntaxExpr hpcSrcSpan ret)
814 815
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
	liftM4 ExprStmt
816
		(addTickLHsCmd c)
817 818
		(addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
819 820 821 822 823 824 825 826 827 828 829 830 831 832
		(return ty)
addTickCmdStmt (LetStmt binds) = do
	liftM LetStmt
		(addTickHsLocalBinds binds)
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' }) }

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

addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
835 836 837 838 839 840 841
addTickHsRecordBinds (HsRecFields fields dd) 
  = do	{ fields' <- mapM process fields
	; return (HsRecFields fields' dd) }
  where
    process (HsRecField ids expr doc)
	= do { expr' <- addTickLHsExpr expr
	     ; return (HsRecField ids expr' doc) }
andy@galois.com's avatar
andy@galois.com committed
842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859

addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
	liftM From
		(addTickLHsExpr e1)
addTickArithSeqInfo (FromThen e1 e2) =
	liftM2 FromThen
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
addTickArithSeqInfo (FromTo e1 e2) =
	liftM2 FromTo
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
addTickArithSeqInfo (FromThenTo e1 e2 e3) =
	liftM3 FromThenTo
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
		(addTickLHsExpr e3)
860 861 862 863 864

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
865 866 867
\end{code}

\begin{code}
868
data TickTransState = TT { tickBoxCount:: Int
869
                         , mixEntries  :: [MixEntry_]
andy@galois.com's avatar
andy@galois.com committed
870
                         }                        
871

872 873 874 875 876
data TickTransEnv = TTE { fileName     :: FastString
                        , density      :: TickDensity
                        , dflags       :: DynFlags
                        , exports      :: NameSet
                        , declPath     :: [String]
877
                        , inScope      :: VarSet
878 879 880
                        , blackList    :: Map SrcSpan ()
                        , this_mod     :: Module
                        }
881

882
--	deriving Show
andy@galois.com's avatar
andy@galois.com committed
883

884
type FreeVars = OccEnv Id
885
noFVs :: FreeVars
886 887 888 889 890 891 892 893 894 895 896 897 898 899
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.

900
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
901 902
        -- a combination of a state monad (TickTransState) and a writer
        -- monad (FreeVars).
andy@galois.com's avatar
andy@galois.com committed
903 904

instance Monad TM where
905
  return a = TM $ \ _env st -> (a,noFVs,st)
906 907
  (TM m) >>= k = TM $ \ env st -> 
		                case m env st of
908
				  (r1,fv1,st1) -> 
909
                                     case unTM (k r1) env st1 of
910 911 912
                                       (r2,fv2,st2) -> 
                                          (r2, fv1 `plusOccEnv` fv2, st2)

Simon Marlow's avatar
Simon Marlow committed
913 914
-- getState :: TM TickTransState
-- getState = TM $ \ env st -> (st, noFVs, st)
andy@galois.com's avatar
andy@galois.com committed
915

916 917
-- setState :: (TickTransState -> TickTransState) -> TM ()
-- setState f = TM $ \ env st -> ((), noFVs, f st)
918

919 920 921 922 923 924
getEnv :: TM TickTransEnv
getEnv = TM $ \ env st -> (env, noFVs, st)

withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv f (TM m) = TM $ \ env st -> 
		                 case m (f env) st of
925 926
                                   (a, fvs, st') -> (a, fvs, st')

927 928 929 930 931 932
getDensity :: TM TickDensity
getDensity = TM $ \env st -> (density env, noFVs, st)

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

933 934
getFreeVars :: TM a -> TM (FreeVars, a)
getFreeVars (TM m) 
935
  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
936 937

freeVar :: Id -> TM ()
938
freeVar id = TM $ \ env st -> 
939
                if id `elemVarSet` inScope env
940 941
                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
                   else ((), noFVs, st)
andy@galois.com's avatar
andy@galois.com committed
942

943 944
addPathEntry :: String -> TM a -> TM a
addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
andy@galois.com's avatar
andy@galois.com committed
945 946

getPathEntry :: TM [String]
947
getPathEntry = declPath `liftM` getEnv
948

949 950 951 952 953 954
getFileName :: TM FastString
getFileName = fileName `liftM` getEnv

sameFileName :: SrcSpan -> TM a -> TM a -> TM a
sameFileName pos out_of_scope in_scope = do
  file_name <- getFileName
955
  case srcSpanFileName_maybe pos of 
956 957 958 959
    Just file_name2 
      | file_name == file_name2 -> in_scope
    _ -> out_of_scope

960 961
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
962
  = TM $ \ env st -> 
963
                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
964
                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
965
  where occs = [ nameOccName (idName id) | id <- new_ids ] 
andy@galois.com's avatar
andy@galois.com committed
966

967 968
isBlackListed :: SrcSpan -> TM Bool
isBlackListed pos = TM $ \ env st -> 
969
	      case Map.lookup pos (blackList env) of
970 971 972
	        Nothing -> (False,noFVs,st)
		Just () -> (True,noFVs,st)

andy@galois.com's avatar
andy@galois.com committed
973 974
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations 
975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007
allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
             -> TM (LHsExpr Id)
allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos =
  sameFileName pos (do e <- m; return (L pos e)) $ do
    (fvs, e) <- getFreeVars m
    env <- getEnv
    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
    return (L pos (HsTick tickish (L pos e)))
allocTickBox _boxLabel _countEntries _topOnly pos m = do
  e <- m
  return (L 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 (Tickish Id))
allocATickBox boxLabel countEntries topOnly  pos fvs | isGoodSrcSpan' pos =
  sameFileName pos (return Nothing) $ do
    let
      mydecl_path = case boxLabel of
                      TopLevelBox x -> x
                      LocalBox xs  -> xs
                      _ -> panic "allocATickBox"
    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
    return (Just tickish)
allocATickBox _boxLabel _countEntries _topOnly _pos _fvs =
  return Nothing


mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
          -> TM (Tickish Id)
mkTickish boxLabel countEntries topOnly pos fvs decl_path =
Ian Lynagh's avatar
Ian Lynagh committed
1008
  TM $ \ env st ->
1009
    let c = tickBoxCount st
1010 1011 1012 1013 1014 1015 1016
        ids = filter (not . isUnLiftedType . idType) $ occEnvElts fvs
            -- unlifted types cause two problems here:
            --   * we can't bind them  at the GHCi prompt
            --     (bindLocalsAtBreakpoint already fliters them out),
            --   * the simplifier might try to substitute a literal for
            --     the Id, and we can't handle that.

1017
        mes = mixEntries st
1018 1019 1020 1021 1022
        me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)

        cc_name | topOnly   = head decl_path
                | otherwise = concat (intersperse "." decl_path)

1023
        cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c)
1024 1025 1026 1027 1028 1029 1030

        count = countEntries && dopt Opt_ProfCountEntries (dflags env)

        tickish
          | opt_Hpc            = HpcTick (this_mod env) c
          | opt_SccProfilingOn = ProfNote cc count True{-scopes-}
          | otherwise          = Breakpoint c ids
1031
    in
1032
    ( tickish
1033 1034 1035
    , fvs
    , st {tickBoxCount=c+1,mixEntries=me:mes}
    )
andy@galois.com's avatar
andy@galois.com committed
1036 1037


1038 1039 1040
allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
                -> TM (LHsExpr Id)
allocBinTickBox boxLabel pos m
1041
 | not opt_Hpc = allocTickBox (ExpBox False) False False pos m
1042 1043 1044
 | isGoodSrcSpan' pos =
 do
 e <- m
Ian Lynagh's avatar
Ian Lynagh committed
1045 1046 1047 1048
 TM $ \ env st ->
  let meT = (pos,declPath env, [],boxLabel True)
      meF = (pos,declPath env, [],boxLabel False)
      meE = (pos,declPath env, [],ExpBox False)
andy@galois.com's avatar
andy@galois.com committed
1049 1050
      c = tickBoxCount st
      mes = mixEntries st
1051
  in 
1052
             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
1053 1054 1055
           -- notice that F and T are reversed,
           -- because we are building the list in
           -- reverse...
1056 1057
             , noFVs
             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
1058
             )
1059
allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
andy@galois.com's avatar
andy@galois.com committed
1060

1061
isGoodSrcSpan' :: SrcSpan -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
1062 1063
isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
isGoodSrcSpan' (UnhelpfulSpan _) = False
1064 1065

mkHpcPos :: SrcSpan -> HpcPos
Ian Lynagh's avatar
Ian Lynagh committed
1066 1067 1068 1069
mkHpcPos pos@(RealSrcSpan s)
   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
                                    srcSpanStartCol s,
                                    srcSpanEndLine s,
1070 1071 1072 1073 1074 1075
                                    srcSpanEndCol s - 1)
                              -- the end column of a SrcSpan is one
                              -- greater than the last column of the
                              -- span (see SrcLoc), whereas HPC
                              -- expects to the column range to be
                              -- inclusive, hence we subtract one above.
Ian Lynagh's avatar
Ian Lynagh committed
1076
mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
andy@galois.com's avatar
andy@galois.com committed
1077

1078
hpcSrcSpan :: SrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
1079
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
andy@galois.com's avatar
andy@galois.com committed
1080 1081 1082
\end{code}


1083 1084 1085 1086 1087 1088 1089 1090
\begin{code}
matchesOneOfMany :: [LMatch Id] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
  where
	matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
\end{code}


andy@galois.com's avatar
andy@galois.com committed
1091
\begin{code}
1092
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
1093 1094 1095 1096 1097 </