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 ({-L pos fn_entry:-}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 = True -- AJG: for now
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 ---------------------------------------------------------------
518 -- Datatypes and file-access routines for the per-module (.mix)
519 -- indexes used by Hpc.
520 -- Colin Runciman and Andy Gill, June 2006
521 ---------------------------------------------------------------
523 -- a module index records the attributes of each tick-box that has
524 -- been introduced in that module, accessed by tick-number position
528 FilePath -- location of original file
529 Integer -- time (in seconds) of original file's last update, since 1970.
530 Int -- tab stop value
531 [MixEntry] -- entries
534 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
535 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
536 -- because if some other program also defined that instance, we will not be able to compile.
538 type MixEntry = (HpcPos, BoxLabel)
540 data BoxLabel = ExpBox
542 | TopLevelBox [String]
544 -- | UserBox (Maybe String)
548 -- | PreludeBinBox String Bool
549 -- | UserBinBox (Maybe String) Bool
550 deriving (Read, Show)
552 mixCreate :: String -> String -> Mix -> IO ()
553 mixCreate dirName modName mix =
554 writeFile (mixName dirName modName) (show mix)
556 readMix :: FilePath -> String -> IO Mix
557 readMix dirName modName = do
558 contents <- readFile (mixName dirName modName)
559 return (read contents)
561 mixName :: FilePath -> String -> String
562 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
564 getModificationTime' :: FilePath -> IO Integer
565 getModificationTime' file = do
566 (TOD sec _) <- System.Directory.getModificationTime file
569 data Tix = Tix [PixEntry] -- The number of tickboxes in each module
570 [TixEntry] -- The tick boxes
571 deriving (Read, Show,Eq)
573 type TixEntry = Integer
575 -- always read and write Tix from the current working directory.
577 readTix :: String -> IO (Maybe Tix)
579 catch (do contents <- readFile $ tixName pname
580 return $ Just $ read contents)
581 (\ _ -> return $ Nothing)
583 writeTix :: String -> Tix -> IO ()
585 writeFile (tixName pname) (show tix)
587 tixName :: String -> String
588 tixName name = name ++ ".tix"
590 -- a program index records module names and numbers of tick-boxes
591 -- introduced in each module that has been transformed for coverage
593 data Pix = Pix [PixEntry] deriving (Read, Show)
595 type PixEntry = ( String -- module name
596 , Int -- number of boxes
599 pixUpdate :: FilePath -> String -> String -> Int -> IO ()
600 pixUpdate dirName progName modName boxCount = do
601 fileUpdate (pixName dirName progName) pixAssign (Pix [])
603 pixAssign :: Pix -> Pix
604 pixAssign (Pix pes) =
605 Pix ((modName,boxCount) : filter ((/=) modName . fst) pes)
607 readPix :: FilePath -> String -> IO Pix
608 readPix dirName pname = do
609 contents <- readFile (pixName dirName pname)
610 return (read contents)
612 tickCount :: Pix -> Int
613 tickCount (Pix mp) = sum $ map snd mp
615 pixName :: FilePath -> String -> String
616 pixName dirName name = dirName ++ "/" ++ name ++ ".pix"
618 -- updating a value stored in a file via read and show
619 fileUpdate :: (Read a, Show a) => String -> (a->a) -> a -> IO()
620 fileUpdate fname update init =
623 valueText <- readFile fname
624 ( case finite valueText of
626 writeFile fname (show (update (read valueText))) ))
627 (const (writeFile fname (show (update init))))
629 finite :: [a] -> Bool
631 finite (x:xs) = finite xs
633 data HpcPos = P !Int !Int !Int !Int deriving (Eq)
635 fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
636 fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2)
638 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
639 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
641 instance Show HpcPos where
642 show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
644 instance Read HpcPos where
645 readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
647 (before,after) = span (/= ',') pos
648 (lhs,rhs) = case span (/= '-') before of
649 (lhs,'-':rhs) -> (lhs,rhs)
650 (lhs,"") -> (lhs,lhs)
651 (l1,':':c1) = span (/= ':') lhs
652 (l2,':':c2) = span (/= ':') rhs