4 \section[Coverage]{@coverage@: the main function}
7 module Coverage (addCoverageTicksToBinds) where
9 #include "HsVersions.h"
24 import System.Time (ClockTime(..))
25 import System.Directory (getModificationTime)
26 import System.IO (FilePath)
27 #if __GLASGOW_HASKELL__ < 603
28 import Compat.Directory ( createDirectoryIfMissing )
30 import System.Directory ( createDirectoryIfMissing )
34 %************************************************************************
36 %* The main function: addCoverageTicksToBinds
38 %************************************************************************
41 addCoverageTicksToBinds dflags mod mod_loc binds = do
43 case ml_hs_file mod_loc of
45 Nothing -> panic "can not find the original file during hpc trans"
47 if "boot" `isSuffixOf` orig_file then return (binds, 0) else do
49 modTime <- getModificationTime' orig_file
51 let mod_name = moduleNameString (moduleName mod)
54 = unTM (addTickLHsBinds binds)
55 $ TT { modName = mod_name
61 let hpc_dir = hpcDir dflags
63 -- write the mix entries for this module
64 let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
66 createDirectoryIfMissing True hpc_dir
68 mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
70 doIfSet_dyn dflags Opt_D_dump_hpc $ do
71 printDump (pprLHsBinds binds1)
72 -- putStrLn (showSDocDebug (pprLHsBinds binds3))
73 return (binds1, tickBoxCount st)
78 liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
79 liftL f (L loc a) = do
83 addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
84 addTickLHsBinds binds = mapBagM addTickLHsBind binds
86 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
87 addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
88 abs_binds' <- addTickLHsBinds abs_binds
89 return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
90 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
91 let name = getOccString id
92 decl_path <- getPathEntry
94 tick_no <- allocATickBox (if null decl_path
95 then TopLevelBox [name]
96 else LocalBox (name : decl_path))
99 mg@(MatchGroup matches' ty) <- addPathEntry (getOccString id)
100 $ addTickMatchGroup (fun_matches funBind)
101 return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
105 -- TODO: Revisit this
106 addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
108 rhs' <- addPathEntry name $ addTickGRHSs False rhs
110 decl_path <- getPathEntry
111 tick_me <- allocTickBox (if null decl_path
112 then TopLevelBox [name]
113 else LocalBox (name : decl_path))
115 return $ L pos $ pat { pat_rhs = rhs' }
117 {- only internal stuff, not from source, uses VarBind, so we ignore it.
118 addTickLHsBind (VarBind var_id var_rhs) = do
119 var_rhs' <- addTickLHsExpr var_rhs
120 return $ VarBind var_id var_rhs'
122 addTickLHsBind other = return other
124 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
125 addTickLHsExpr (L pos e0) = do
126 e1 <- addTickHsExpr e0
127 fn <- allocTickBox ExpBox pos
128 return $ fn $ L pos e1
130 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
131 addTickLHsExprOptAlt oneOfMany (L pos e0) = do
132 e1 <- addTickHsExpr e0
133 fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos
134 return $ fn $ L pos e1
136 -- version of addTick that does not actually add a tick,
137 -- because the scope of this tick is completely subsumed by
139 addTickLHsExpr' :: LHsExpr Id -> TM (LHsExpr Id)
140 addTickLHsExpr' (L pos e0) = do
141 e1 <- addTickHsExpr e0
144 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
145 addBinTickLHsExpr boxLabel (L pos e0) = do
146 e1 <- addTickHsExpr e0
147 allocBinTickBox boxLabel $ L pos e1
150 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
151 addTickHsExpr e@(HsVar _) = return e
152 addTickHsExpr e@(HsIPVar _) = return e
153 addTickHsExpr e@(HsOverLit _) = return e
154 addTickHsExpr e@(HsLit _) = return e
155 addTickHsExpr e@(HsLam matchgroup) =
156 liftM HsLam (addTickMatchGroup matchgroup)
157 addTickHsExpr (HsApp e1 e2) =
158 liftM2 HsApp (addTickLHsExpr' e1) (addTickLHsExpr e2)
159 addTickHsExpr (OpApp e1 e2 fix e3) =
165 addTickHsExpr ( NegApp e neg) =
168 (addTickSyntaxExpr hpcSrcSpan neg)
169 addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExpr' e)
170 addTickHsExpr (SectionL e1 e2) =
174 addTickHsExpr (SectionR e1 e2) =
178 addTickHsExpr (HsCase e mgs) =
181 (addTickMatchGroup mgs)
182 addTickHsExpr (HsIf e1 e2 e3) =
184 (addBinTickLHsExpr CondBinBox e1)
185 (addTickLHsExprOptAlt True e2)
186 (addTickLHsExprOptAlt True e3)
187 addTickHsExpr (HsLet binds e) =
189 (addTickHsLocalBinds binds) -- to think about: !patterns.
191 addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
194 (mapM (liftL (addTickStmt forQual)) stmts)
195 (addTickLHsExpr last_exp)
198 forQual = case cxt of
199 ListComp -> Just QualBinBox
201 addTickHsExpr (ExplicitList ty es) =
204 (mapM addTickLHsExpr es)
205 addTickHsExpr (ExplicitPArr {}) = error "addTickHsExpr: ExplicitPArr "
206 addTickHsExpr (ExplicitTuple es box) =
208 (mapM addTickLHsExpr es)
210 addTickHsExpr (RecordCon id ty rec_binds) =
214 (addTickHsRecordBinds rec_binds)
215 addTickHsExpr (RecordUpd e rec_binds ty1 ty2) =
218 (addTickHsRecordBinds rec_binds)
221 addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
222 addTickHsExpr (ExprWithTySigOut e ty) =
223 liftM2 ExprWithTySigOut
224 (addTickLHsExpr' e) -- No need to tick the inner expression
225 -- for expressions with signatures
227 addTickHsExpr (ArithSeq ty arith_seq) =
230 (addTickArithSeqInfo arith_seq)
231 addTickHsExpr (HsTickPragma (file,(l1,c1),(l2,c2)) (L pos e0)) = do
232 e1 <- addTickHsExpr e0
233 fn <- allocTickBox (ExternalBox (unpackFS file) (P l1 c1 l2 c2)) pos
234 let (L _ e2) = fn $ L pos e1
236 addTickHsExpr (PArrSeq {}) = error "addTickHsExpr: PArrSeq "
237 addTickHsExpr (HsSCC {}) = error "addTickHsExpr: HsSCC "
238 addTickHsExpr (HsCoreAnn {}) = error "addTickHsExpr: HsCoreAnn "
239 addTickHsExpr e@(HsBracket {}) = return e
240 addTickHsExpr e@(HsBracketOut {}) = return e
241 addTickHsExpr e@(HsSpliceE {}) = return e
242 addTickHsExpr (HsProc pat cmdtop) =
245 (liftL addTickHsCmdTop cmdtop)
246 addTickHsExpr (HsWrap w e) =
249 (addTickHsExpr e) -- explicitly no tick on inside
250 addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) =
257 addTickHsExpr (HsArrForm e fix cmdtop) =
261 (mapM (liftL addTickHsCmdTop) cmdtop)
263 addTickHsExpr e@(HsType ty) = return e
265 -- Should never happen in expression content.
266 addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
267 addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
268 addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
269 addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
270 addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
272 addTickMatchGroup (MatchGroup matches ty) = do
273 let isOneOfMany = matchesOneOfMany matches
274 matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
275 return $ MatchGroup matches' ty
277 addTickMatch :: Bool -> Match Id -> TM (Match Id)
278 addTickMatch isOneOfMany (Match pats opSig gRHSs) = do
279 gRHSs' <- addTickGRHSs isOneOfMany gRHSs
280 return $ Match pats opSig gRHSs'
282 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
283 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
284 guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
285 local_binds' <- addTickHsLocalBinds local_binds
286 return $ GRHSs guarded' local_binds'
288 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
289 addTickGRHS isOneOfMany (GRHS stmts expr) = do
290 stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
291 expr' <- addTickLHsExprOptAlt isOneOfMany expr
292 return $ GRHS stmts' expr'
295 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
296 addTickStmt isGuard (BindStmt pat e bind fail) =
300 (addTickSyntaxExpr hpcSrcSpan bind)
301 (addTickSyntaxExpr hpcSrcSpan fail)
302 addTickStmt isGuard (ExprStmt e bind' ty) =
305 (addTickSyntaxExpr hpcSrcSpan bind')
308 addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
309 | otherwise = addTickLHsExpr e
311 addTickStmt isGuard (LetStmt binds) =
313 (addTickHsLocalBinds binds)
314 addTickStmt isGuard (ParStmt pairs) =
315 liftM ParStmt (mapM process pairs)
317 process (stmts,ids) =
319 (mapM (liftL (addTickStmt isGuard)) stmts)
321 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
323 (mapM (liftL (addTickStmt isGuard)) stmts)
327 (addTickDictBinds dictbinds)
329 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
330 addTickHsLocalBinds (HsValBinds binds) =
332 (addTickHsValBinds binds)
333 addTickHsLocalBinds (HsIPBinds binds) =
335 (addTickHsIPBinds binds)
336 addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
338 addTickHsValBinds (ValBindsOut binds sigs) =
340 (mapM (\ (rec,binds') ->
343 (addTickLHsBinds binds'))
347 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
349 (mapM (liftL addTickIPBind) ipbinds)
350 (addTickDictBinds dictbinds)
352 addTickIPBind :: IPBind Id -> TM (IPBind Id)
353 addTickIPBind (IPBind nm e) =
358 -- There is no location here, so we might need to use a context location??
359 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
360 addTickSyntaxExpr pos x = do
361 L _ x' <- addTickLHsExpr (L pos x)
363 -- we do not walk into patterns.
364 addTickLPat :: LPat Id -> TM (LPat Id)
365 addTickLPat pat = return pat
367 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
368 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
375 addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
376 addTickLHsCmd x = addTickLHsExpr x
378 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
379 addTickDictBinds x = addTickLHsBinds x
381 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
382 addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs)
387 (addTickLHsExpr expr)
389 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
390 addTickArithSeqInfo (From e1) =
393 addTickArithSeqInfo (FromThen e1 e2) =
397 addTickArithSeqInfo (FromTo e1 e2) =
401 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
409 data TickTransState = TT { modName :: String
410 , declPath :: [String]
412 , mixEntries :: [MixEntry]
416 data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
418 instance Monad TM where
419 return a = TM $ \ st -> (a,st)
420 (TM m) >>= k = TM $ \ st -> case m st of
421 (r1,st1) -> unTM (k r1) st1
423 --addTick :: LHsExpr Id -> TM (LHsExpr Id)
424 --addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
426 addPathEntry :: String -> TM a -> TM a
427 addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
428 (r,st') -> (r,st' { declPath = declPath st })
430 getPathEntry :: TM [String]
431 getPathEntry = TM $ \ st -> (declPath st,st)
433 -- the tick application inherits the source position of its
434 -- expression argument to support nested box allocations
435 allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
436 allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
437 let me = (hpcPos,boxLabel)
440 in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
441 , st {tickBoxCount=c+1,mixEntries=me:mes}
443 allocTickBox boxLabel e = return id
445 -- the tick application inherits the source position of its
446 -- expression argument to support nested box allocations
447 allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
448 allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
449 let me = (hpcPos,boxLabel)
453 , st {tickBoxCount=c+1,mixEntries=me:mes}
455 allocATickBox boxLabel e = return Nothing
457 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
458 allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
459 let meT = (hpcPos,boxLabel True)
460 meF = (hpcPos,boxLabel False)
461 meE = (hpcPos,ExpBox)
464 in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
465 -- notice that F and T are reversed,
466 -- because we are building the list in
468 , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
471 allocBinTickBox boxLabel e = return e
473 mkHpcPos :: SrcSpan -> Maybe HpcPos
475 | not (isGoodSrcSpan pos) = Nothing
476 | start == end = Nothing -- no actual location
477 | otherwise = Just hpcPos
479 start = srcSpanStart pos
481 hpcPos = toHpcPos ( srcLocLine start
482 , srcLocCol start + 1
487 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
492 matchesOneOfMany :: [LMatch Id] -> Bool
493 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
495 matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
500 ---------------------------------------------------------------
501 -- Datatypes and file-access routines for the per-module (.mix)
502 -- indexes used by Hpc.
503 -- Colin Runciman and Andy Gill, June 2006
504 ---------------------------------------------------------------
506 -- a module index records the attributes of each tick-box that has
507 -- been introduced in that module, accessed by tick-number position
511 FilePath -- location of original file
512 Integer -- time (in seconds) of original file's last update, since 1970.
513 Int -- tab stop value
514 [MixEntry] -- entries
517 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
518 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
519 -- because if some other program also defined that instance, we will not be able to compile.
521 type MixEntry = (HpcPos, BoxLabel)
523 data BoxLabel = ExpBox
525 | TopLevelBox [String]
530 | ExternalBox String HpcPos
531 -- ^The position was generated from the named file/module,
532 -- with the stated position (inside the named file/module).
533 -- The HpcPos inside this MixEntry refers to the generated Haskell location.
534 deriving (Read, Show)
536 mixCreate :: String -> String -> Mix -> IO ()
537 mixCreate dirName modName mix =
538 writeFile (mixName dirName modName) (show mix)
540 mixName :: FilePath -> String -> String
541 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
543 getModificationTime' :: FilePath -> IO Integer
544 getModificationTime' file = do
545 (TOD sec _) <- System.Directory.getModificationTime file
548 -- a program index records module names and numbers of tick-boxes
549 -- introduced in each module that has been transformed for coverage
551 data HpcPos = P !Int !Int !Int !Int deriving (Eq)
553 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
554 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
556 instance Show HpcPos where
557 show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
559 instance Read HpcPos where
560 readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
562 (before,after) = span (/= ',') pos
563 (lhs,rhs) = case span (/= '-') before of
564 (lhs,'-':rhs) -> (lhs,rhs)
565 (lhs,"") -> (lhs,lhs)
566 (l1,':':c1) = span (/= ':') lhs
567 (l2,':':c2) = span (/= ':') rhs