Coverage.lhs 25.3 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 6 7 8 9 10 11 12
%
\section[Coverage]{@coverage@: the main function}

\begin{code}
module Coverage (addCoverageTicksToBinds) where

import HsSyn
import Module
import Outputable
13
import DynFlags
andy@galois.com's avatar
andy@galois.com committed
14 15
import Monad		
import SrcLoc
16
import ErrUtils
andy@galois.com's avatar
andy@galois.com committed
17 18
import Name
import Bag
19
import Id
20
import VarSet
21 22
import Data.List
import FastString
23
import HscTypes	
24
import StaticFlags
25
import TyCon
26
import FiniteMap
27
import Maybes
andy@galois.com's avatar
andy@galois.com committed
28

29
import Data.Array
andy@galois.com's avatar
andy@galois.com committed
30
import System.Directory ( createDirectoryIfMissing )
31

32 33 34
import Trace.Hpc.Mix
import Trace.Hpc.Util

35
import BreakArray 
36
import Data.HashTable   ( hashString )
andy@galois.com's avatar
andy@galois.com committed
37 38
\end{code}

39

andy@galois.com's avatar
andy@galois.com committed
40 41 42 43 44 45 46
%************************************************************************
%*									*
%* 		The main function: addCoverageTicksToBinds
%*									*
%************************************************************************

\begin{code}
47 48 49 50
addCoverageTicksToBinds
        :: DynFlags
        -> Module
        -> ModLocation          -- of the current module
51
        -> [TyCon]		-- type constructor in this module
52
        -> LHsBinds Id
53
        -> IO (LHsBinds Id, HpcInfo, ModBreaks)
54

55
addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do 
56

57
  let orig_file = 
58 59
             case ml_hs_file mod_loc of
		    Just file -> file
60
		    Nothing -> panic "can not find the original file during hpc trans"
61

62
  if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
63

64 65 66 67 68 69 70 71
  -- Now, we 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
  let orig_file2 = case top_pos of
		     (file_name:_) 
		       | ".hsc" `isSuffixOf` unpackFS file_name -> unpackFS file_name
		     _ -> orig_file

andy@galois.com's avatar
andy@galois.com committed
72 73
  let mod_name = moduleNameString (moduleName mod)

74
  let (binds1,_,st)
andy@galois.com's avatar
andy@galois.com committed
75
		 = unTM (addTickLHsBinds binds) 
76
		   (TTE
77
		       { fileName    = mkFastString orig_file2
andy@galois.com's avatar
andy@galois.com committed
78
		      , declPath     = []
79
                      , inScope      = emptyVarSet
80 81
		      , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),()) 
		      		       		| tyCon <- tyCons ]
82
		       })
83 84
		   (TT 
		      { tickBoxCount = 0
andy@galois.com's avatar
andy@galois.com committed
85
		      , mixEntries   = []
86
		      })
andy@galois.com's avatar
andy@galois.com committed
87

88
  let entries = reverse $ mixEntries st
andy@galois.com's avatar
andy@galois.com committed
89 90

  -- write the mix entries for this module
91
  hashNo <- if opt_Hpc then do
92
     let hpc_dir = hpcDir dflags
93 94 95 96 97

     let hpc_mod_dir = if modulePackageId mod == mainPackageId 
		       then hpc_dir
		       else hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)

98
     let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
99
     createDirectoryIfMissing True hpc_mod_dir
100
     modTime <- getModificationTime orig_file2
101
     let entries' = [ (hpcPos, box) 
102
                    | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
103 104
     when (length entries' /= tickBoxCount st) $ do
       panic "the number of .mix entries are inconsistent"
105
     let hashNo = mixHash orig_file2 modTime tabStop entries'
106
     mixCreate hpc_mod_dir mod_name 
107
     	       $ Mix orig_file2 modTime (toHash hashNo) tabStop entries'
108 109 110
     return $ hashNo 
   else do
     return $ 0
111 112 113

  -- Todo: use proper src span type
  breakArray <- newBreakArray $ length entries
114

115
  let locsTicks = listArray (0,tickBoxCount st-1) 
116
                     [ span | (span,_,_) <- entries ]
117
      varsTicks = listArray (0,tickBoxCount st-1) 
118
                     [ vars | (_,vars,_) <- entries ]
119
      modBreaks = emptyModBreaks 
120 121
                  { modBreaks_flags = breakArray 
                  , modBreaks_locs  = locsTicks 
122
                  , modBreaks_vars  = varsTicks
123
                  } 
andy@galois.com's avatar
andy@galois.com committed
124 125 126

  doIfSet_dyn dflags  Opt_D_dump_hpc $ do
	  printDump (pprLHsBinds binds1)
127

128
  return (binds1, HpcInfo (tickBoxCount st) hashNo, modBreaks)
andy@galois.com's avatar
andy@galois.com committed
129 130 131 132 133 134 135 136 137 138 139 140 141
\end{code}


\begin{code}
liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
liftL f (L loc a) = do
  a' <- f a
  return $ L loc a'

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

addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
142
addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
andy@galois.com's avatar
andy@galois.com committed
143 144
  abs_binds' <- addTickLHsBinds abs_binds
  return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
145
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
andy@galois.com's avatar
andy@galois.com committed
146 147 148
  let name = getOccString id
  decl_path <- getPathEntry

149
  (fvs, (MatchGroup matches' ty)) <- 
150
        getFreeVars $
151
        addPathEntry name $
152
        addTickMatchGroup (fun_matches funBind)
153

154 155
  blackListed <- isBlackListed pos

156
  -- Todo: we don't want redundant ticks on simple pattern bindings
157 158
  -- We don't want to generate code for blacklisted positions
  if blackListed || (not opt_Hpc && isSimplePatBind funBind)
159 160 161 162 163 164 165
     then 
        return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
                                 , fun_tick = Nothing 
                                 }
     else do
        tick_no <- allocATickBox (if null decl_path
                                     then TopLevelBox [name]
166
                                     else LocalBox (decl_path ++ [name])) 
167
                                pos fvs
168 169 170 171 172 173 174 175

        return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
                                 , fun_tick = tick_no
                                 }
   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
176 177 178 179

-- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
  let name = "(...)"
180
  rhs' <- addPathEntry name $ addTickGRHSs False rhs
andy@galois.com's avatar
andy@galois.com committed
181 182 183 184 185 186 187 188
{-
  decl_path <- getPathEntry
  tick_me <- allocTickBox (if null decl_path
			   then TopLevelBox [name]
			   else LocalBox (name : decl_path))
-}			   
  return $ L pos $ pat { pat_rhs = rhs' }

189 190
-- 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
191

192 193 194
-- Add a tick to the expression no matter what it is.  There is one exception:
-- for the debugger, if the expression is a 'let', then we don't want to add
-- a tick here because there will definititely be a tick on the body anyway.
195
addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
196 197 198
addTickLHsExprAlways (L pos e0)
  | not opt_Hpc, HsLet _ _ <- e0 = addTickLHsExprNever (L pos e0)
  | otherwise = allocTickBox (ExpBox False) pos $ addTickHsExpr e0
andy@galois.com's avatar
andy@galois.com committed
199

200 201 202
addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNeverOrAlways e
    | opt_Hpc   = addTickLHsExprNever e
203 204
    | otherwise = addTickLHsExprAlways e

205 206 207 208 209
addTickLHsExprNeverOrMaybe :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNeverOrMaybe e
    | opt_Hpc   = addTickLHsExprNever e
    | otherwise = addTickLHsExpr e

210 211 212 213 214 215 216 217
-- 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

218 219 220 221 222
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExpr (L pos e0) = do
    if opt_Hpc || isGoodBreakExpr e0
       then do
223
          allocTickBox (ExpBox False) pos $ addTickHsExpr e0
224 225
       else do
          e1 <- addTickHsExpr e0
226 227 228 229 230 231 232 233 234 235 236 237 238
          return $ L pos e1 

-- 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 (HsCase {})    = True
isGoodBreakExpr (HsIf {})      = True
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {})  = True
isGoodBreakExpr (PArrSeq {})   = True
239
isGoodBreakExpr _other         = False 
240

andy@galois.com's avatar
andy@galois.com committed
241
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
242 243
addTickLHsExprOptAlt oneOfMany (L pos e0)
  | not opt_Hpc = addTickLHsExpr (L pos e0)
244
  | otherwise =
245
    allocTickBox (ExpBox oneOfMany) pos $ 
246
        addTickHsExpr e0
andy@galois.com's avatar
andy@galois.com committed
247 248

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
249 250 251
addBinTickLHsExpr boxLabel (L pos e0) =
    allocBinTickBox boxLabel pos $
        addTickHsExpr e0
andy@galois.com's avatar
andy@galois.com committed
252 253

addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
254
addTickHsExpr e@(HsVar id) = do freeVar id; return e
andy@galois.com's avatar
andy@galois.com committed
255 256 257
addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsLit _) = return e
258
addTickHsExpr (HsLam matchgroup) =
andy@galois.com's avatar
andy@galois.com committed
259 260
        liftM HsLam (addTickMatchGroup matchgroup)
addTickHsExpr (HsApp e1 e2) = 
261
	liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
andy@galois.com's avatar
andy@galois.com committed
262 263 264
addTickHsExpr (OpApp e1 e2 fix e3) = 
	liftM4 OpApp 
		(addTickLHsExpr e1) 
265
		(addTickLHsExprNever e2)
andy@galois.com's avatar
andy@galois.com committed
266 267
		(return fix)
		(addTickLHsExpr e3)
268
addTickHsExpr (NegApp e neg) =
andy@galois.com's avatar
andy@galois.com committed
269 270 271
	liftM2 NegApp
		(addTickLHsExpr e) 
		(addTickSyntaxExpr hpcSrcSpan neg)
272
addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNeverOrMaybe e)
andy@galois.com's avatar
andy@galois.com committed
273 274 275 276 277 278 279 280
addTickHsExpr (SectionL e1 e2) = 
	liftM2 SectionL
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
addTickHsExpr (SectionR e1 e2) = 
	liftM2 SectionR
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
281 282 283 284
addTickHsExpr (ExplicitTuple es boxity) =
        liftM2 ExplicitTuple
                (mapM addTickTupArg es)
                (return boxity)
andy@galois.com's avatar
andy@galois.com committed
285 286 287 288 289 290
addTickHsExpr (HsCase e mgs) = 
	liftM2 HsCase
		(addTickLHsExpr e) 
		(addTickMatchGroup mgs)
addTickHsExpr (HsIf	 e1 e2 e3) = 
	liftM3 HsIf
291
		(addBinTickLHsExpr (BinBox CondBinBox) e1)
andy@galois.com's avatar
andy@galois.com committed
292 293 294
		(addTickLHsExprOptAlt True e2)
		(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
295
	bindLocals (map unLoc $ collectLocalBinders binds) $
andy@galois.com's avatar
andy@galois.com committed
296
	liftM2 HsLet
297 298
		(addTickHsLocalBinds binds) -- to think about: !patterns.
                (addTickLHsExprNeverOrAlways e)
299 300 301 302
addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
        (stmts', last_exp') <- addTickLStmts' forQual stmts 
                                     (addTickLHsExpr last_exp)
	return (HsDo cxt stmts' last_exp' srcloc)
andy@galois.com's avatar
andy@galois.com committed
303 304
  where
	forQual = case cxt of
305
		    ListComp -> Just $ BinBox QualBinBox
andy@galois.com's avatar
andy@galois.com committed
306 307
		    _        -> Nothing
addTickHsExpr (ExplicitList ty es) = 
308
	liftM2 ExplicitList
andy@galois.com's avatar
andy@galois.com committed
309
		(return ty)
310
		(mapM (addTickLHsExpr) es)
311 312 313 314
addTickHsExpr (ExplicitPArr ty es) =
	liftM2 ExplicitPArr
		(return ty)
		(mapM (addTickLHsExpr) es)
315
addTickHsExpr (RecordCon id ty rec_binds) = 
andy@galois.com's avatar
andy@galois.com committed
316 317 318 319
	liftM3 RecordCon
		(return id)
		(return ty)
		(addTickHsRecordBinds rec_binds)
320 321
addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
	liftM5 RecordUpd
andy@galois.com's avatar
andy@galois.com committed
322 323
		(addTickLHsExpr e)
		(addTickHsRecordBinds rec_binds)
324 325
		(return cons) (return tys1) (return tys2)

andy@galois.com's avatar
andy@galois.com committed
326 327
addTickHsExpr (ExprWithTySigOut e ty) =
	liftM2 ExprWithTySigOut
328
		(addTickLHsExprNever e) -- No need to tick the inner expression
andy@galois.com's avatar
andy@galois.com committed
329 330 331 332 333 334
				    -- for expressions with signatures
		(return ty)
addTickHsExpr (ArithSeq	 ty arith_seq) =
	liftM2 ArithSeq	
		(return ty)
		(addTickArithSeqInfo arith_seq)
335
addTickHsExpr (HsTickPragma _ (L pos e0)) = do
336
    e2 <- allocTickBox (ExpBox False) pos $
337
                addTickHsExpr e0
338
    return $ unLoc e2
339 340 341 342 343 344 345 346 347 348 349 350
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
351 352 353 354 355 356
addTickHsExpr e@(HsBracket     {}) = return e
addTickHsExpr e@(HsBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {}) = return e
addTickHsExpr (HsProc pat cmdtop) =
	liftM2 HsProc
		(addTickLPat pat)
357
		(liftL (addTickHsCmdTop) cmdtop)
andy@galois.com's avatar
andy@galois.com committed
358 359 360 361
addTickHsExpr (HsWrap w e) = 
	liftM2 HsWrap
		(return w)
		(addTickHsExpr e)	-- explicitly no tick on inside
362 363 364 365 366 367 368 369 370 371 372
addTickHsExpr (HsArrApp	 e1 e2 ty1 arr_ty lr) = 
        liftM5 HsArrApp
	       (addTickLHsExpr e1)
	       (addTickLHsExpr e2)
	       (return ty1)
	       (return arr_ty)
	       (return lr)
addTickHsExpr (HsArrForm e fix cmdtop) = 
        liftM3 HsArrForm
	       (addTickLHsExpr e)
	       (return fix)
373
	       (mapM (liftL (addTickHsCmdTop)) cmdtop)
374

375
addTickHsExpr e@(HsType _) = return e
376

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

380 381 382 383
addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)

384
addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
andy@galois.com's avatar
andy@galois.com committed
385
addTickMatchGroup (MatchGroup matches ty) = do
386
  let isOneOfMany = matchesOneOfMany matches
andy@galois.com's avatar
andy@galois.com committed
387 388 389 390
  matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
  return $ MatchGroup matches' ty

addTickMatch :: Bool -> Match Id -> TM (Match Id)
391 392 393 394
addTickMatch isOneOfMany (Match pats opSig gRHSs) =
  bindLocals (collectPatsBinders pats) $ do
    gRHSs' <- addTickGRHSs isOneOfMany gRHSs
    return $ Match pats opSig gRHSs'
andy@galois.com's avatar
andy@galois.com committed
395 396 397

addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
398
  bindLocals binders $ do
399
    local_binds' <- addTickHsLocalBinds local_binds
400 401 402 403
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
    return $ GRHSs guarded' local_binds'
  where
    binders = map unLoc (collectLocalBinders local_binds)
andy@galois.com's avatar
andy@galois.com committed
404 405

addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
406
addTickGRHS isOneOfMany (GRHS stmts expr) = do
407
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
408
                        (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
409
                                    else addTickLHsExprAlways expr)
andy@galois.com's avatar
andy@galois.com committed
410 411
  return $ GRHS stmts' expr'

412 413
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts isGuard stmts = do
414 415 416 417 418 419 420 421 422 423 424 425 426 427
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a 
               -> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
  = bindLocals binders $ do
        lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
        a <- res
        return (lstmts', a)
  where
        binders = map unLoc (collectLStmtsBinders lstmts)

addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
428
addTickStmt _isGuard (BindStmt pat e bind fail) = do
429
	liftM4 BindStmt
andy@galois.com's avatar
andy@galois.com committed
430
		(addTickLPat pat)
431
		(addTickLHsExprAlways e)
andy@galois.com's avatar
andy@galois.com committed
432 433
		(addTickSyntaxExpr hpcSrcSpan bind)
		(addTickSyntaxExpr hpcSrcSpan fail)
434
addTickStmt isGuard (ExprStmt e bind' ty) = do
435
	liftM3 ExprStmt
436
		(addTick isGuard e)
andy@galois.com's avatar
andy@galois.com committed
437 438
		(addTickSyntaxExpr hpcSrcSpan bind')
		(return ty)
439
addTickStmt _isGuard (LetStmt binds) = do
440 441
	liftM LetStmt
		(addTickHsLocalBinds binds)
442
addTickStmt isGuard (ParStmt pairs) = do
443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
    liftM ParStmt 
        (mapM (addTickStmtAndBinders isGuard) pairs)
addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
    liftM3 TransformStmt 
        (addTickStmtAndBinders isGuard (stmts, ids))
        (addTickLHsExprAlways usingExpr)
        (addTickMaybeByLHsExpr maybeByExpr)
addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
    liftM2 GroupStmt 
        (addTickStmtAndBinders isGuard (stmts, binderMap))
        (case groupByClause of
            GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
            GroupBySomething eitherUsingExpr byExpr -> do
                eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
                byExpr' <- addTickLHsExprAlways byExpr
                return $ GroupBySomething eitherUsingExpr' byExpr')
    where
        mapEitherM f g x = do
          case x of
            Left a -> f a >>= (return . Left)
            Right b -> g b >>= (return . Right)
464
addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
465
  	liftM5 RecStmt 
466
		(addTickLStmts isGuard stmts)
andy@galois.com's avatar
andy@galois.com committed
467 468 469 470 471
		(return ids1)
		(return ids2)
		(return tys)
		(addTickDictBinds dictbinds)

472
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
473 474 475
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
                  | otherwise          = addTickLHsExprAlways e

476 477
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) 
                      -> TM ([LStmt Id], a)
478 479 480 481 482 483 484 485 486 487 488
addTickStmtAndBinders isGuard (stmts, ids) = 
    liftM2 (,) 
        (addTickLStmts isGuard stmts)
        (return ids)

addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
addTickMaybeByLHsExpr maybeByExpr = 
    case maybeByExpr of
        Nothing -> return Nothing
        Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)

andy@galois.com's avatar
andy@galois.com committed
489 490 491 492 493 494 495 496 497
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) = 
	liftM HsValBinds 
		(addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  = 
	liftM HsIPBinds 
		(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

498
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
andy@galois.com's avatar
andy@galois.com committed
499 500 501 502 503 504 505 506
addTickHsValBinds (ValBindsOut binds sigs) =
	liftM2 ValBindsOut
		(mapM (\ (rec,binds') -> 
				liftM2 (,)
					(return rec)
					(addTickLHsBinds binds'))
			binds)
		(return sigs)
507
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
508

509
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
andy@galois.com's avatar
andy@galois.com committed
510 511
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
	liftM2 IPBinds
512
		(mapM (liftL (addTickIPBind)) ipbinds)
andy@galois.com's avatar
andy@galois.com committed
513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537
		(addTickDictBinds dictbinds)

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)

538
addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
andy@galois.com's avatar
andy@galois.com committed
539 540 541 542 543 544
addTickLHsCmd x = addTickLHsExpr x

addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
addTickDictBinds x = addTickLHsBinds x

addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
545 546 547 548 549 550 551
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
552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572

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)
\end{code}

\begin{code}
573
data TickTransState = TT { tickBoxCount:: Int
574
                         , mixEntries  :: [MixEntry_]
andy@galois.com's avatar
andy@galois.com committed
575
                         }                        
576

577
data TickTransEnv = TTE { fileName      :: FastString
578
			, declPath     :: [String]
579
                        , inScope      :: VarSet
580
			, blackList   :: FiniteMap SrcSpan ()
581 582
			}

583
--	deriving Show
andy@galois.com's avatar
andy@galois.com committed
584

585
type FreeVars = OccEnv Id
586
noFVs :: FreeVars
587 588 589 590 591 592 593 594 595 596 597 598 599 600
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.

601
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
602 603
        -- a combination of a state monad (TickTransState) and a writer
        -- monad (FreeVars).
andy@galois.com's avatar
andy@galois.com committed
604 605

instance Monad TM where
606
  return a = TM $ \ _env st -> (a,noFVs,st)
607 608
  (TM m) >>= k = TM $ \ env st -> 
		                case m env st of
609
				  (r1,fv1,st1) -> 
610
                                     case unTM (k r1) env st1 of
611 612 613
                                       (r2,fv2,st2) -> 
                                          (r2, fv1 `plusOccEnv` fv2, st2)

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

617 618
-- setState :: (TickTransState -> TickTransState) -> TM ()
-- setState f = TM $ \ env st -> ((), noFVs, f st)
619

620 621 622 623 624 625
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
626 627 628 629
                                   (a, fvs, st') -> (a, fvs, st')

getFreeVars :: TM a -> TM (FreeVars, a)
getFreeVars (TM m) 
630
  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
631 632

freeVar :: Id -> TM ()
633
freeVar id = TM $ \ env st -> 
634
                if id `elemVarSet` inScope env
635 636
                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
                   else ((), noFVs, st)
andy@galois.com's avatar
andy@galois.com committed
637

638 639
addPathEntry :: String -> TM a -> TM a
addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
andy@galois.com's avatar
andy@galois.com committed
640 641

getPathEntry :: TM [String]
642
getPathEntry = declPath `liftM` getEnv
643

644 645 646 647 648 649
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
650
  case srcSpanFileName_maybe pos of 
651 652 653 654
    Just file_name2 
      | file_name == file_name2 -> in_scope
    _ -> out_of_scope

655 656
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
657
  = TM $ \ env st -> 
658
                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
659
                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
660
  where occs = [ nameOccName (idName id) | id <- new_ids ] 
andy@galois.com's avatar
andy@galois.com committed
661

662 663 664 665 666 667
isBlackListed :: SrcSpan -> TM Bool
isBlackListed pos = TM $ \ env st -> 
	      case lookupFM (blackList env) pos of
	        Nothing -> (False,noFVs,st)
		Just () -> (True,noFVs,st)

andy@galois.com's avatar
andy@galois.com committed
668 669
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations 
670
allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
671 672 673
allocTickBox boxLabel pos m | isGoodSrcSpan' pos = 
  sameFileName pos 
    (do e <- m; return (L pos e)) $ do
674
  (fvs, e) <- getFreeVars m
675
  TM $ \ _env st ->
676 677 678
    let c = tickBoxCount st
        ids = occEnvElts fvs
        mes = mixEntries st
679 680
        me = (pos, map (nameOccName.idName) ids, boxLabel)
    in
681 682 683 684
    ( L pos (HsTick c ids (L pos e))
    , fvs
    , st {tickBoxCount=c+1,mixEntries=me:mes}
    )
685
allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
andy@galois.com's avatar
andy@galois.com committed
686 687 688

-- the tick application inherits the source position of its
-- expression argument to support nested box allocations 
689
allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
690 691
allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
  sameFileName pos 
692
    (return Nothing) $ TM $ \ _env st ->
693
  let me = (pos, map (nameOccName.idName) ids, boxLabel)
andy@galois.com's avatar
andy@galois.com committed
694 695
      c = tickBoxCount st
      mes = mixEntries st
696
      ids = occEnvElts fvs
697
  in ( Just (c, ids)
698 699
     , noFVs
     , st {tickBoxCount=c+1, mixEntries=me:mes}
andy@galois.com's avatar
andy@galois.com committed
700
     )
701
allocATickBox _boxLabel _pos _fvs = return Nothing
andy@galois.com's avatar
andy@galois.com committed
702

703 704 705 706 707 708 709 710
allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
                -> TM (LHsExpr Id)
allocBinTickBox boxLabel pos m
 | not opt_Hpc = allocTickBox (ExpBox False) pos m
 | isGoodSrcSpan' pos =
 do
 e <- m
 TM $ \ _env st ->
711 712 713
  let meT = (pos,[],boxLabel True)
      meF = (pos,[],boxLabel False)
      meE = (pos,[],ExpBox False)
andy@galois.com's avatar
andy@galois.com committed
714 715
      c = tickBoxCount st
      mes = mixEntries st
716
  in 
717
             ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
718 719 720
           -- notice that F and T are reversed,
           -- because we are building the list in
           -- reverse...
721 722
             , noFVs
             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
723
             )
724
allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
andy@galois.com's avatar
andy@galois.com committed
725

726
isGoodSrcSpan' :: SrcSpan -> Bool
727 728 729 730 731 732 733 734 735
isGoodSrcSpan' pos
   | not (isGoodSrcSpan pos) = False
   | start == end            = False
   | otherwise		     = True
  where
   start = srcSpanStart pos
   end   = srcSpanEnd pos

mkHpcPos :: SrcSpan -> HpcPos
andy@galois.com's avatar
andy@galois.com committed
736
mkHpcPos pos 
737 738
   | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
   | otherwise		      = hpcPos
andy@galois.com's avatar
andy@galois.com committed
739 740 741 742
  where
   start = srcSpanStart pos
   end   = srcSpanEnd pos
   hpcPos = toHpcPos ( srcLocLine start
743
		     , srcLocCol start + 1
andy@galois.com's avatar
andy@galois.com committed
744 745 746 747
		     , srcLocLine end
		     , srcLocCol end
		     )

748
hpcSrcSpan :: SrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
749
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
andy@galois.com's avatar
andy@galois.com committed
750 751 752
\end{code}


753 754 755 756 757 758 759 760
\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
761
\begin{code}
762
type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
763 764 765 766 767 768 769

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

770
mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
771 772
mixHash file tm tabstop entries = fromIntegral $ hashString
	(show $ Mix file tm 0 tabstop entries)
andy@galois.com's avatar
andy@galois.com committed
773
\end{code}