4 \section[Coverage]{@coverage@: the main function}
7 module Coverage (addCoverageTicksToBinds) where
9 #include "HsVersions.h"
13 import DynFlags ( DynFlags, mainModIs, mainFunIs )
15 import HscTypes ( HpcInfo, noHpcInfo )
19 import DynFlags ( DynFlag(Opt_D_dump_hpc), hpcDir )
23 import ErrUtils (doIfSet_dyn)
24 import HsUtils ( mkHsApp )
34 import TysWiredIn ( intTy , stringTy, unitTy, intDataCon, falseDataConId, mkListTy, pairTyCon, tupleCon, mkTupleTy, unboxedSingletonDataCon )
36 import Var ( TyVar, mkTyVar )
37 import DataCon ( dataConWrapId )
40 import BasicTypes ( RecFlag(..), Activation(NeverActive), Boxity(..) )
41 import Data.List ( isSuffixOf )
43 import System.Time (ClockTime(..))
44 import System.Directory (getModificationTime)
45 import System.IO (FilePath)
46 #if __GLASGOW_HASKELL__ < 603
47 import Compat.Directory ( createDirectoryIfMissing )
49 import System.Directory ( createDirectoryIfMissing )
53 %************************************************************************
55 %* The main function: addCoverageTicksToBinds
57 %************************************************************************
60 addCoverageTicksToBinds dflags mod mod_loc binds = do
61 let main_mod = mainModIs dflags
62 main_is = case mainFunIs dflags of
66 let mod_name = moduleNameString (moduleName mod)
69 = unTM (addTickLHsBinds binds)
70 $ TT { modName = mod_name
76 let hpc_dir = hpcDir dflags
78 -- write the mix entries for this module
79 let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
81 let orig_file = case ml_hs_file mod_loc of
83 Nothing -> error "can not find the original file during hpc trans"
85 modTime <- getModificationTime' orig_file
87 createDirectoryIfMissing True hpc_dir
89 mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
91 doIfSet_dyn dflags Opt_D_dump_hpc $ do
92 printDump (pprLHsBinds binds1)
93 -- putStrLn (showSDocDebug (pprLHsBinds binds3))
94 return (binds1, tickBoxCount st)
99 liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
100 liftL f (L loc a) = do
104 addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
105 addTickLHsBinds binds = mapBagM addTickLHsBind binds
107 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
108 addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
109 abs_binds' <- addTickLHsBinds abs_binds
110 return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
111 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
112 let name = getOccString id
113 decl_path <- getPathEntry
115 tick_no <- allocATickBox (if null decl_path
116 then TopLevelBox [name]
117 else LocalBox (name : decl_path))
120 mg@(MatchGroup matches' ty) <- addPathEntry (getOccString id)
121 $ addTickMatchGroup (fun_matches funBind)
122 let arg_count = matchGroupArity mg
123 let (tys,res_ty) = splitFunTysN arg_count ty
125 return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
129 -- TODO: Revisit this
130 addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
132 rhs' <- addPathEntry name $ addTickGRHSs False rhs
134 decl_path <- getPathEntry
135 tick_me <- allocTickBox (if null decl_path
136 then TopLevelBox [name]
137 else LocalBox (name : decl_path))
139 return $ L pos $ pat { pat_rhs = rhs' }
141 {- only internal stuff, not from source, uses VarBind, so we ignore it.
142 addTickLHsBind (VarBind var_id var_rhs) = do
143 var_rhs' <- addTickLHsExpr var_rhs
144 return $ VarBind var_id var_rhs'
146 addTickLHsBind other = return other
148 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
149 addTickLHsExpr (L pos e0) = do
150 e1 <- addTickHsExpr e0
151 fn <- allocTickBox ExpBox pos
152 return $ fn $ L pos e1
154 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
155 addTickLHsExprOptAlt oneOfMany (L pos e0) = do
156 e1 <- addTickHsExpr e0
157 fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos
158 return $ fn $ L pos e1
160 -- version of addTick that does not actually add a tick,
161 -- because the scope of this tick is completely subsumed by
163 addTickLHsExpr' :: LHsExpr Id -> TM (LHsExpr Id)
164 addTickLHsExpr' (L pos e0) = do
165 e1 <- addTickHsExpr e0
168 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
169 addBinTickLHsExpr boxLabel (L pos e0) = do
170 e1 <- addTickHsExpr e0
171 allocBinTickBox boxLabel $ L pos e1
174 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
175 addTickHsExpr e@(HsVar _) = return e
176 addTickHsExpr e@(HsIPVar _) = return e
177 addTickHsExpr e@(HsOverLit _) = return e
178 addTickHsExpr e@(HsLit _) = return e
179 addTickHsExpr e@(HsLam matchgroup) =
180 liftM HsLam (addTickMatchGroup matchgroup)
181 addTickHsExpr (HsApp e1 e2) =
182 liftM2 HsApp (addTickLHsExpr' e1) (addTickLHsExpr e2)
183 addTickHsExpr (OpApp e1 e2 fix e3) =
189 addTickHsExpr ( NegApp e neg) =
192 (addTickSyntaxExpr hpcSrcSpan neg)
193 addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExpr' e)
194 addTickHsExpr (SectionL e1 e2) =
198 addTickHsExpr (SectionR e1 e2) =
202 addTickHsExpr (HsCase e mgs) =
205 (addTickMatchGroup mgs)
206 addTickHsExpr (HsIf e1 e2 e3) =
208 (addBinTickLHsExpr CondBinBox e1)
209 (addTickLHsExprOptAlt True e2)
210 (addTickLHsExprOptAlt True e3)
211 addTickHsExpr (HsLet binds e) =
213 (addTickHsLocalBinds binds) -- to think about: !patterns.
215 addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
218 (mapM (liftL (addTickStmt forQual)) stmts)
219 (addTickLHsExpr last_exp)
222 forQual = case cxt of
223 ListComp -> Just QualBinBox
225 addTickHsExpr (ExplicitList ty es) =
228 (mapM addTickLHsExpr es)
229 addTickHsExpr (ExplicitPArr {}) = error "addTickHsExpr: ExplicitPArr "
230 addTickHsExpr (ExplicitTuple es box) =
232 (mapM addTickLHsExpr es)
234 addTickHsExpr (RecordCon id ty rec_binds) =
238 (addTickHsRecordBinds rec_binds)
239 addTickHsExpr (RecordUpd e rec_binds ty1 ty2) =
242 (addTickHsRecordBinds rec_binds)
245 addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
246 addTickHsExpr (ExprWithTySigOut e ty) =
247 liftM2 ExprWithTySigOut
248 (addTickLHsExpr' e) -- No need to tick the inner expression
249 -- for expressions with signatures
251 addTickHsExpr (ArithSeq ty arith_seq) =
254 (addTickArithSeqInfo arith_seq)
255 addTickHsExpr (PArrSeq {}) = error "addTickHsExpr: PArrSeq "
256 addTickHsExpr (HsSCC {}) = error "addTickHsExpr: HsSCC "
257 addTickHsExpr (HsCoreAnn {}) = error "addTickHsExpr: HsCoreAnn "
258 addTickHsExpr e@(HsBracket {}) = return e
259 addTickHsExpr e@(HsBracketOut {}) = return e
260 addTickHsExpr e@(HsSpliceE {}) = return e
261 addTickHsExpr (HsProc pat cmdtop) =
264 (liftL addTickHsCmdTop cmdtop)
265 addTickHsExpr (HsWrap w e) =
268 (addTickHsExpr e) -- explicitly no tick on inside
269 addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) =
276 addTickHsExpr (HsArrForm e fix cmdtop) =
280 (mapM (liftL addTickHsCmdTop) cmdtop)
282 addTickHsExpr e@(HsType ty) = return e
284 -- Should never happen in expression content.
285 addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
286 addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
287 addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
288 addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
289 addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
291 addTickMatchGroup (MatchGroup matches ty) = do
292 let isOneOfMany = matchesOneOfMany matches
293 matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
294 return $ MatchGroup matches' ty
296 addTickMatch :: Bool -> Match Id -> TM (Match Id)
297 addTickMatch isOneOfMany (Match pats opSig gRHSs) = do
298 gRHSs' <- addTickGRHSs isOneOfMany gRHSs
299 return $ Match pats opSig gRHSs'
301 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
302 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
303 guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
304 local_binds' <- addTickHsLocalBinds local_binds
305 return $ GRHSs guarded' local_binds'
307 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
308 addTickGRHS isOneOfMany (GRHS stmts expr) = do
309 stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
310 expr' <- addTickLHsExprOptAlt isOneOfMany expr
311 return $ GRHS stmts' expr'
314 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
315 addTickStmt isGuard (BindStmt pat e bind fail) =
319 (addTickSyntaxExpr hpcSrcSpan bind)
320 (addTickSyntaxExpr hpcSrcSpan fail)
321 addTickStmt isGuard (ExprStmt e bind' ty) =
324 (addTickSyntaxExpr hpcSrcSpan bind')
327 addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
328 | otherwise = addTickLHsExpr e
330 addTickStmt isGuard (LetStmt binds) =
332 (addTickHsLocalBinds binds)
333 addTickStmt isGuard (ParStmt pairs) =
334 liftM ParStmt (mapM process pairs)
336 process (stmts,ids) =
338 (mapM (liftL (addTickStmt isGuard)) stmts)
340 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
342 (mapM (liftL (addTickStmt isGuard)) stmts)
346 (addTickDictBinds dictbinds)
348 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
349 addTickHsLocalBinds (HsValBinds binds) =
351 (addTickHsValBinds binds)
352 addTickHsLocalBinds (HsIPBinds binds) =
354 (addTickHsIPBinds binds)
355 addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
357 addTickHsValBinds (ValBindsOut binds sigs) =
359 (mapM (\ (rec,binds') ->
362 (addTickLHsBinds binds'))
366 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
368 (mapM (liftL addTickIPBind) ipbinds)
369 (addTickDictBinds dictbinds)
371 addTickIPBind :: IPBind Id -> TM (IPBind Id)
372 addTickIPBind (IPBind nm e) =
377 -- There is no location here, so we might need to use a context location??
378 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
379 addTickSyntaxExpr pos x = do
380 L _ x' <- addTickLHsExpr (L pos x)
382 -- we do not walk into patterns.
383 addTickLPat :: LPat Id -> TM (LPat Id)
384 addTickLPat pat = return pat
386 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
387 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
394 addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
395 addTickLHsCmd x = addTickLHsExpr x
397 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
398 addTickDictBinds x = addTickLHsBinds x
400 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
401 addTickHsRecordBinds pairs = mapM process pairs
406 (addTickLHsExpr expr)
408 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
409 addTickArithSeqInfo (From e1) =
412 addTickArithSeqInfo (FromThen e1 e2) =
416 addTickArithSeqInfo (FromTo e1 e2) =
420 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
428 data TixFlags = TixFlags
430 data TickTransState = TT { modName :: String
431 , declPath :: [String]
433 , mixEntries :: [MixEntry]
437 data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
439 instance Monad TM where
440 return a = TM $ \ st -> (a,st)
441 (TM m) >>= k = TM $ \ st -> case m st of
442 (r1,st1) -> unTM (k r1) st1
444 --addTick :: LHsExpr Id -> TM (LHsExpr Id)
445 --addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
447 addPathEntry :: String -> TM a -> TM a
448 addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
449 (r,st') -> (r,st' { declPath = declPath st })
451 getPathEntry :: TM [String]
452 getPathEntry = TM $ \ st -> (declPath st,st)
454 -- the tick application inherits the source position of its
455 -- expression argument to support nested box allocations
456 allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
457 allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
458 let me = (hpcPos,boxLabel)
461 in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
462 , st {tickBoxCount=c+1,mixEntries=me:mes}
464 allocTickBox boxLabel e = return id
466 -- the tick application inherits the source position of its
467 -- expression argument to support nested box allocations
468 allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
469 allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
470 let me = (hpcPos,boxLabel)
474 , st {tickBoxCount=c+1,mixEntries=me:mes}
476 allocATickBox boxLabel e = return Nothing
478 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
479 allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
480 let meT = (hpcPos,boxLabel True)
481 meF = (hpcPos,boxLabel False)
482 meE = (hpcPos,ExpBox)
485 in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
486 -- notice that F and T are reversed,
487 -- because we are building the list in
489 , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
492 allocBinTickBox boxLabel e = return e
494 mkHpcPos :: SrcSpan -> Maybe HpcPos
496 | not (isGoodSrcSpan pos) = Nothing
497 | start == end = Nothing -- no actual location
498 | otherwise = Just hpcPos
500 start = srcSpanStart pos
502 hpcPos = toHpcPos ( srcLocLine start
503 , srcLocCol start + 1
508 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
510 -- all newly allocated locations have an HPC tag on them, to help debuging
511 hpcLoc :: e -> Located e
512 hpcLoc = L hpcSrcSpan
517 matchesOneOfMany :: [LMatch Id] -> Bool
518 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
520 matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
525 ---------------------------------------------------------------
526 -- Datatypes and file-access routines for the per-module (.mix)
527 -- indexes used by Hpc.
528 -- Colin Runciman and Andy Gill, June 2006
529 ---------------------------------------------------------------
531 -- a module index records the attributes of each tick-box that has
532 -- been introduced in that module, accessed by tick-number position
536 FilePath -- location of original file
537 Integer -- time (in seconds) of original file's last update, since 1970.
538 Int -- tab stop value
539 [MixEntry] -- entries
542 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
543 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
544 -- because if some other program also defined that instance, we will not be able to compile.
546 type MixEntry = (HpcPos, BoxLabel)
548 data BoxLabel = ExpBox
550 | TopLevelBox [String]
552 -- | UserBox (Maybe String)
556 -- | PreludeBinBox String Bool
557 -- | UserBinBox (Maybe String) Bool
558 deriving (Read, Show)
560 mixCreate :: String -> String -> Mix -> IO ()
561 mixCreate dirName modName mix =
562 writeFile (mixName dirName modName) (show mix)
564 readMix :: FilePath -> String -> IO Mix
565 readMix dirName modName = do
566 contents <- readFile (mixName dirName modName)
567 return (read contents)
569 mixName :: FilePath -> String -> String
570 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
572 getModificationTime' :: FilePath -> IO Integer
573 getModificationTime' file = do
574 (TOD sec _) <- System.Directory.getModificationTime file
577 data Tix = Tix [PixEntry] -- The number of tickboxes in each module
578 [TixEntry] -- The tick boxes
579 deriving (Read, Show,Eq)
581 type TixEntry = Integer
583 -- always read and write Tix from the current working directory.
585 readTix :: String -> IO (Maybe Tix)
587 catch (do contents <- readFile $ tixName pname
588 return $ Just $ read contents)
589 (\ _ -> return $ Nothing)
591 writeTix :: String -> Tix -> IO ()
593 writeFile (tixName pname) (show tix)
595 tixName :: String -> String
596 tixName name = name ++ ".tix"
598 -- a program index records module names and numbers of tick-boxes
599 -- introduced in each module that has been transformed for coverage
601 data Pix = Pix [PixEntry] deriving (Read, Show)
603 type PixEntry = ( String -- module name
604 , Int -- number of boxes
607 pixUpdate :: FilePath -> String -> String -> Int -> IO ()
608 pixUpdate dirName progName modName boxCount = do
609 fileUpdate (pixName dirName progName) pixAssign (Pix [])
611 pixAssign :: Pix -> Pix
612 pixAssign (Pix pes) =
613 Pix ((modName,boxCount) : filter ((/=) modName . fst) pes)
615 readPix :: FilePath -> String -> IO Pix
616 readPix dirName pname = do
617 contents <- readFile (pixName dirName pname)
618 return (read contents)
620 tickCount :: Pix -> Int
621 tickCount (Pix mp) = sum $ map snd mp
623 pixName :: FilePath -> String -> String
624 pixName dirName name = dirName ++ "/" ++ name ++ ".pix"
626 -- updating a value stored in a file via read and show
627 fileUpdate :: (Read a, Show a) => String -> (a->a) -> a -> IO()
628 fileUpdate fname update init =
631 valueText <- readFile fname
632 ( case finite valueText of
634 writeFile fname (show (update (read valueText))) ))
635 (const (writeFile fname (show (update init))))
637 finite :: [a] -> Bool
639 finite (x:xs) = finite xs
641 data HpcPos = P !Int !Int !Int !Int deriving (Eq)
643 fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
644 fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2)
646 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
647 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
649 instance Show HpcPos where
650 show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
652 instance Read HpcPos where
653 readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
655 (before,after) = span (/= ',') pos
656 (lhs,rhs) = case span (/= '-') before of
657 (lhs,'-':rhs) -> (lhs,rhs)
658 (lhs,"") -> (lhs,lhs)
659 (l1,':':c1) = span (/= ':') lhs
660 (l2,':':c2) = span (/= ':') rhs