\section[Coverage]{@coverage@: the main function}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Coverage (addCoverageTicksToBinds) where
#include "HsVersions.h"
import BreakArray
import Data.HashTable ( hashString )
-
\end{code}
:: DynFlags
-> Module
-> ModLocation -- of the current module
- -> [TyCon] -- type constructor in this module
+ -> [TyCon] -- type constructor in this module
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, ModBreaks)
, inScope = emptyVarSet
, blackList = listToFM [ (getSrcSpan (tyConName tyCon),())
| tyCon <- tyCons ]
- , declBlock = noSrcSpan })
+ })
(TT
{ tickBoxCount = 0
, mixEntries = []
createDirectoryIfMissing True hpc_mod_dir
modTime <- getModificationTime orig_file
let entries' = [ (hpcPos, box)
- | (span,_,box,_) <- entries, hpcPos <- [mkHpcPos span] ]
+ | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
when (length entries' /= tickBoxCount st) $ do
panic "the number of .mix entries are inconsistent"
let hashNo = mixHash orig_file modTime tabStop entries'
breakArray <- newBreakArray $ length entries
let locsTicks = listArray (0,tickBoxCount st-1)
- [ span | (span,_,_,_) <- entries ]
+ [ span | (span,_,_) <- entries ]
varsTicks = listArray (0,tickBoxCount st-1)
- [ vars | (_,vars,_,_) <- entries ]
- declsTicks = listArray (0,tickBoxCount st-1)
- [ decls| (_,_,_,decls) <- entries ]
+ [ vars | (_,vars,_) <- entries ]
modBreaks = emptyModBreaks
{ modBreaks_flags = breakArray
, modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
- , modBreaks_decls = declsTicks
}
doIfSet_dyn dflags Opt_D_dump_hpc $ do
(fvs, mg@(MatchGroup matches' ty)) <-
getFreeVars $
- addPathEntry name pos $
+ addPathEntry name $
addTickMatchGroup (fun_matches funBind)
blackListed <- isBlackListed pos
-- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
let name = "(...)"
- rhs' <- addPathEntry name pos $ addTickGRHSs False rhs
+ rhs' <- addPathEntry name $ addTickGRHSs False rhs
{-
decl_path <- getPathEntry
tick_me <- allocTickBox (if null decl_path
-}
return $ L pos $ pat { pat_rhs = rhs' }
-{- only internal stuff, not from source, uses VarBind, so we ignore it.
-addTickLHsBind (VarBind var_id var_rhs) = do
- var_rhs' <- addTickLHsExpr var_rhs
- return $ VarBind var_id var_rhs'
--}
-addTickLHsBind other = return other
+-- Only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
-- 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
binders = map unLoc (collectLocalBinders local_binds)
addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
-addTickGRHS isOneOfMany (GRHS stmts expr@(L pos _)) = do
+addTickGRHS isOneOfMany (GRHS stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
- else addPathEntry "" pos $ addTickLHsExprAlways expr)
+ else addTickLHsExprAlways expr)
return $ GRHS stmts' expr'
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' ty) = do
liftM3 ExprStmt
- (addTick e)
+ (addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(return ty)
- where
- addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
- | otherwise = addTickLHsExprAlways e
-
addTickStmt isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs) = do
- liftM ParStmt (mapM process pairs)
- where
- process (stmts,ids) =
- liftM2 (,)
- (addTickLStmts isGuard stmts)
- (return ids)
+ 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)
addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
liftM5 RecStmt
(addTickLStmts isGuard stmts)
(return tys)
(addTickDictBinds dictbinds)
+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
+ | otherwise = addTickLHsExprAlways e
+
+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)
+
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
, declPath :: [String]
, inScope :: VarSet
, blackList :: FiniteMap SrcSpan ()
- , declBlock :: SrcSpan
}
-- deriving Show
then ((), unitOccEnv (nameOccName (idName id)) id, st)
else ((), noFVs, st)
-addPathEntry :: String -> SrcSpan -> TM a -> TM a
-addPathEntry nm src = withEnv (\ env -> env { declPath = declPath env ++ [nm], declBlock = src })
+addPathEntry :: String -> TM a -> TM a
+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
getPathEntry :: TM [String]
getPathEntry = declPath `liftM` getEnv
bindLocals new_ids (TM m)
= TM $ \ env st ->
case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
- (r, fv, st') -> (r, fv `delListFromUFM` occs, st')
+ (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
where occs = [ nameOccName (idName id) | id <- new_ids ]
isBlackListed :: SrcSpan -> TM Bool
let c = tickBoxCount st
ids = occEnvElts fvs
mes = mixEntries st
- parentBlock = if declBlock env == noSrcSpan then pos else declBlock env
- me = (pos, map (nameOccName.idName) ids, boxLabel, parentBlock)
- in
+ me = (pos, map (nameOccName.idName) ids, boxLabel)
+ in
( L pos (HsTick c ids (L pos e))
, fvs
, st {tickBoxCount=c+1,mixEntries=me:mes}
allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
sameFileName pos
(return Nothing) $ TM $ \ env st ->
- let parentBlock = if declBlock env == noSrcSpan then pos else declBlock env
- me = (pos, map (nameOccName.idName) ids, boxLabel, parentBlock)
+ let me = (pos, map (nameOccName.idName) ids, boxLabel)
c = tickBoxCount st
mes = mixEntries st
ids = occEnvElts fvs
allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ env st ->
- let parentBlock = if declBlock env == noSrcSpan then pos else declBlock env
- meT = (pos,[],boxLabel True, parentBlock)
- meF = (pos,[],boxLabel False, parentBlock)
- meE = (pos,[],ExpBox False, parentBlock)
+ let meT = (pos,[],boxLabel True)
+ meF = (pos,[],boxLabel False)
+ meE = (pos,[],ExpBox False)
c = tickBoxCount st
mes = mixEntries st
in
, noFVs
, st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
)
- else ( L pos $ HsTick c [] $ L pos e
+ else
+ ( L pos $ HsTick c [] $ L pos e
, noFVs
, st {tickBoxCount=c+1,mixEntries=meE:mes}
)
\begin{code}
-type ParentDecl= SrcSpan
-type TickSpan = SrcSpan
-type MixEntry_ = (TickSpan, [OccName], BoxLabel, ParentDecl)
+type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
-- For the hash value, we hash everything: the file name,
-- the timestamp of the original source file, the tab stop,
projects / ghc-hetmet.git / blobdiff