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 {}) = error "addTickHsExpr: HsArrApp "
270 addTickHsExpr (HsArrForm {}) = error "addTickHsExpr: HsArrForm"
271 addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
272 addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
273 addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
274 addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
275 addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
277 addTickHsExpr e@(HsType ty) = return e
279 -- catch all, and give an error message.
280 --addTickHsExpr e = error ("addTickLhsExpr: " ++ showSDoc (ppr e))
283 addTickMatchGroup (MatchGroup matches ty) = do
284 let isOneOfMany = True -- AJG: for now
285 matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
286 return $ MatchGroup matches' ty
288 addTickMatch :: Bool -> Match Id -> TM (Match Id)
289 addTickMatch isOneOfMany (Match pats opSig gRHSs) = do
290 gRHSs' <- addTickGRHSs isOneOfMany gRHSs
291 return $ Match pats opSig gRHSs'
293 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
294 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
295 guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
296 local_binds' <- addTickHsLocalBinds local_binds
297 return $ GRHSs guarded' local_binds'
299 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
300 addTickGRHS isOneOfMany (GRHS stmts expr) = do
301 stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
302 expr' <- addTickLHsExprOptAlt isOneOfMany expr
303 return $ GRHS stmts' expr'
306 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
307 addTickStmt isGuard (BindStmt pat e bind fail) =
311 (addTickSyntaxExpr hpcSrcSpan bind)
312 (addTickSyntaxExpr hpcSrcSpan fail)
313 addTickStmt isGuard (ExprStmt e bind' ty) =
316 (addTickSyntaxExpr hpcSrcSpan bind')
319 addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
320 | otherwise = addTickLHsExpr e
322 addTickStmt isGuard (LetStmt binds) =
324 (addTickHsLocalBinds binds)
325 addTickStmt isGuard (ParStmt pairs) =
326 liftM ParStmt (mapM process pairs)
328 process (stmts,ids) =
330 (mapM (liftL (addTickStmt isGuard)) stmts)
332 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
334 (mapM (liftL (addTickStmt isGuard)) stmts)
338 (addTickDictBinds dictbinds)
340 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
341 addTickHsLocalBinds (HsValBinds binds) =
343 (addTickHsValBinds binds)
344 addTickHsLocalBinds (HsIPBinds binds) =
346 (addTickHsIPBinds binds)
347 addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
349 addTickHsValBinds (ValBindsOut binds sigs) =
351 (mapM (\ (rec,binds') ->
354 (addTickLHsBinds binds'))
358 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
360 (mapM (liftL addTickIPBind) ipbinds)
361 (addTickDictBinds dictbinds)
363 addTickIPBind :: IPBind Id -> TM (IPBind Id)
364 addTickIPBind (IPBind nm e) =
369 -- There is no location here, so we might need to use a context location??
370 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
371 addTickSyntaxExpr pos x = do
372 L _ x' <- addTickLHsExpr (L pos x)
374 -- we do not walk into patterns.
375 addTickLPat :: LPat Id -> TM (LPat Id)
376 addTickLPat pat = return pat
378 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
379 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
386 addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
387 addTickLHsCmd x = addTickLHsExpr x
389 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
390 addTickDictBinds x = addTickLHsBinds x
392 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
393 addTickHsRecordBinds pairs = mapM process pairs
398 (addTickLHsExpr expr)
400 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
401 addTickArithSeqInfo (From e1) =
404 addTickArithSeqInfo (FromThen e1 e2) =
408 addTickArithSeqInfo (FromTo e1 e2) =
412 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
420 data TixFlags = TixFlags
422 data TickTransState = TT { modName :: String
423 , declPath :: [String]
425 , mixEntries :: [MixEntry]
429 data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
431 instance Monad TM where
432 return a = TM $ \ st -> (a,st)
433 (TM m) >>= k = TM $ \ st -> case m st of
434 (r1,st1) -> unTM (k r1) st1
436 --addTick :: LHsExpr Id -> TM (LHsExpr Id)
437 --addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
439 addPathEntry :: String -> TM a -> TM a
440 addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
441 (r,st') -> (r,st' { declPath = declPath st })
443 getPathEntry :: TM [String]
444 getPathEntry = TM $ \ st -> (declPath st,st)
446 -- the tick application inherits the source position of its
447 -- expression argument to support nested box allocations
448 allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
449 allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
450 let me = (hpcPos,boxLabel)
453 in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
454 , st {tickBoxCount=c+1,mixEntries=me:mes}
456 allocTickBox boxLabel e = return id
458 -- the tick application inherits the source position of its
459 -- expression argument to support nested box allocations
460 allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
461 allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
462 let me = (hpcPos,boxLabel)
466 , st {tickBoxCount=c+1,mixEntries=me:mes}
468 allocATickBox boxLabel e = return Nothing
470 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
471 allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
472 let meT = (hpcPos,boxLabel True)
473 meF = (hpcPos,boxLabel False)
474 meE = (hpcPos,ExpBox)
477 in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
478 -- notice that F and T are reversed,
479 -- because we are building the list in
481 , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
484 allocBinTickBox boxLabel e = return e
486 mkHpcPos :: SrcSpan -> Maybe HpcPos
488 | not (isGoodSrcSpan pos) = Nothing
489 | start == end = Nothing -- no actual location
490 | otherwise = Just hpcPos
492 start = srcSpanStart pos
494 hpcPos = toHpcPos ( srcLocLine start
495 , srcLocCol start + 1
500 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
502 -- all newly allocated locations have an HPC tag on them, to help debuging
503 hpcLoc :: e -> Located e
504 hpcLoc = L hpcSrcSpan
509 ---------------------------------------------------------------
510 -- Datatypes and file-access routines for the per-module (.mix)
511 -- indexes used by Hpc.
512 -- Colin Runciman and Andy Gill, June 2006
513 ---------------------------------------------------------------
515 -- a module index records the attributes of each tick-box that has
516 -- been introduced in that module, accessed by tick-number position
520 FilePath -- location of original file
521 Integer -- time (in seconds) of original file's last update, since 1970.
522 Int -- tab stop value
523 [MixEntry] -- entries
526 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
527 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
528 -- because if some other program also defined that instance, we will not be able to compile.
530 type MixEntry = (HpcPos, BoxLabel)
532 data BoxLabel = ExpBox
534 | TopLevelBox [String]
536 -- | UserBox (Maybe String)
540 -- | PreludeBinBox String Bool
541 -- | UserBinBox (Maybe String) Bool
542 deriving (Read, Show)
544 mixCreate :: String -> String -> Mix -> IO ()
545 mixCreate dirName modName mix =
546 writeFile (mixName dirName modName) (show mix)
548 readMix :: FilePath -> String -> IO Mix
549 readMix dirName modName = do
550 contents <- readFile (mixName dirName modName)
551 return (read contents)
553 mixName :: FilePath -> String -> String
554 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
556 getModificationTime' :: FilePath -> IO Integer
557 getModificationTime' file = do
558 (TOD sec _) <- System.Directory.getModificationTime file
561 data Tix = Tix [PixEntry] -- The number of tickboxes in each module
562 [TixEntry] -- The tick boxes
563 deriving (Read, Show,Eq)
565 type TixEntry = Integer
567 -- always read and write Tix from the current working directory.
569 readTix :: String -> IO (Maybe Tix)
571 catch (do contents <- readFile $ tixName pname
572 return $ Just $ read contents)
573 (\ _ -> return $ Nothing)
575 writeTix :: String -> Tix -> IO ()
577 writeFile (tixName pname) (show tix)
579 tixName :: String -> String
580 tixName name = name ++ ".tix"
582 -- a program index records module names and numbers of tick-boxes
583 -- introduced in each module that has been transformed for coverage
585 data Pix = Pix [PixEntry] deriving (Read, Show)
587 type PixEntry = ( String -- module name
588 , Int -- number of boxes
591 pixUpdate :: FilePath -> String -> String -> Int -> IO ()
592 pixUpdate dirName progName modName boxCount = do
593 fileUpdate (pixName dirName progName) pixAssign (Pix [])
595 pixAssign :: Pix -> Pix
596 pixAssign (Pix pes) =
597 Pix ((modName,boxCount) : filter ((/=) modName . fst) pes)
599 readPix :: FilePath -> String -> IO Pix
600 readPix dirName pname = do
601 contents <- readFile (pixName dirName pname)
602 return (read contents)
604 tickCount :: Pix -> Int
605 tickCount (Pix mp) = sum $ map snd mp
607 pixName :: FilePath -> String -> String
608 pixName dirName name = dirName ++ "/" ++ name ++ ".pix"
610 -- updating a value stored in a file via read and show
611 fileUpdate :: (Read a, Show a) => String -> (a->a) -> a -> IO()
612 fileUpdate fname update init =
615 valueText <- readFile fname
616 ( case finite valueText of
618 writeFile fname (show (update (read valueText))) ))
619 (const (writeFile fname (show (update init))))
621 finite :: [a] -> Bool
623 finite (x:xs) = finite xs
625 data HpcPos = P !Int !Int !Int !Int deriving (Eq)
627 fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
628 fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2)
630 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
631 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
633 instance Show HpcPos where
634 show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
636 instance Read HpcPos where
637 readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
639 (before,after) = span (/= ',') pos
640 (lhs,rhs) = case span (/= '-') before of
641 (lhs,'-':rhs) -> (lhs,rhs)
642 (lhs,"") -> (lhs,lhs)
643 (l1,':':c1) = span (/= ':') lhs
644 (l2,':':c2) = span (/= ':') rhs