1 ---------------------------------------------------------
2 -- The main program for the hpc-report tool, part of HPC.
3 -- Colin Runciman and Andy Gill, June 2006
4 ---------------------------------------------------------
6 module HpcReport (report_plugin) where
8 import Prelude hiding (exp)
9 import List(sort,intersperse)
13 import Control.Monad hiding (guard)
14 import qualified HpcSet as Set
16 notExpecting :: String -> a
17 notExpecting s = error ("not expecting "++s)
19 data BoxTixCounts = BT {boxCount, tixCount :: !Int}
21 btZero :: BoxTixCounts
22 btZero = BT {boxCount=0, tixCount=0}
24 btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts
25 btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2)
27 btPercentage :: String -> BoxTixCounts -> String
28 btPercentage s (BT b t) = showPercentage s t b
30 showPercentage :: String -> Int -> Int -> String
31 showPercentage s 0 0 = "100% "++s++" (0/0)"
32 showPercentage s n d = showWidth 3 p++"% "++
34 " ("++show n++"/"++show d++")"
37 showWidth w x0 = replicate (shortOf w (length sx)) ' ' ++ sx
40 shortOf x y = if y < x then x-y else 0
42 data BinBoxTixCounts = BBT { binBoxCount
45 , bothTixCount :: !Int}
47 bbtzero :: BinBoxTixCounts
48 bbtzero = BBT { binBoxCount=0
53 bbtPlus :: BinBoxTixCounts -> BinBoxTixCounts -> BinBoxTixCounts
54 bbtPlus (BBT b1 tt1 ft1 bt1) (BBT b2 tt2 ft2 bt2) =
55 BBT (b1+b2) (tt1+tt2) (ft1+ft2) (bt1+bt2)
57 bbtPercentage :: String -> Bool -> BinBoxTixCounts -> String
58 bbtPercentage s withdetail (BBT b tt ft bt) =
59 showPercentage s bt b ++
60 if withdetail && bt/=b then
61 detailFor tt "always True"++
62 detailFor ft "always False"++
63 detailFor (b-(tt+ft+bt)) "unevaluated"
66 detailFor n txt = if n>0 then ", "++show n++" "++txt
69 data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts
70 , guard,cond,qual :: !BinBoxTixCounts
71 , decPaths :: [[String]]}
74 miZero = MI { exp=btZero
83 miPlus :: ModInfo -> ModInfo -> ModInfo
85 MI { exp = exp mi1 `btPlus` exp mi2
86 , alt = alt mi1 `btPlus` alt mi2
87 , top = top mi1 `btPlus` top mi2
88 , loc = loc mi1 `btPlus` loc mi2
89 , guard = guard mi1 `bbtPlus` guard mi2
90 , cond = cond mi1 `bbtPlus` cond mi2
91 , qual = qual mi1 `bbtPlus` qual mi2
92 , decPaths = decPaths mi1 ++ decPaths mi2 }
94 allBinCounts :: ModInfo -> BinBoxTixCounts
96 BBT { binBoxCount = sumAll binBoxCount
97 , onlyTrueTixCount = sumAll onlyTrueTixCount
98 , onlyFalseTixCount = sumAll onlyFalseTixCount
99 , bothTixCount = sumAll bothTixCount }
101 sumAll f = f (guard mi) + f (cond mi) + f (qual mi)
103 accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo
104 accumCounts [] mi = mi
105 accumCounts ((bl,btc):etc) mi | single bl =
109 ExpBox False -> mi{exp = inc (exp mi)}
110 ExpBox True -> mi{exp = inc (exp mi), alt = inc (alt mi)}
111 TopLevelBox dp -> mi{top = inc (top mi)
112 ,decPaths = upd dp (decPaths mi)}
113 LocalBox dp -> mi{loc = inc (loc mi)
114 ,decPaths = upd dp (decPaths mi)}
115 _other -> notExpecting "BoxLabel in accumcounts"
116 inc (BT {boxCount=bc,tixCount=tc}) =
118 , tixCount = tc + bit (btc>0) }
120 if btc>0 then dps else dp:dps
121 accumCounts ((bl0,btc0):(bl1,btc1):etc) mi =
124 mi' = case (bl0,bl1) of
125 (BinBox GuardBinBox True, BinBox GuardBinBox False) ->
126 mi{guard = inc (guard mi)}
127 (BinBox CondBinBox True, BinBox CondBinBox False) ->
128 mi{cond = inc (cond mi)}
129 (BinBox QualBinBox True, BinBox QualBinBox False) ->
130 mi{qual = inc (qual mi)}
131 _other -> notExpecting "BoxLabel pair in accumcounts"
132 inc (BBT { binBoxCount=bbc
133 , onlyTrueTixCount=ttc
134 , onlyFalseTixCount=ftc
135 , bothTixCount=btc}) =
136 BBT { binBoxCount = bbc+1
137 , onlyTrueTixCount = ttc + bit (btc0 >0 && btc1==0)
138 , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0)
139 , bothTixCount = btc + bit (btc0 >0 && btc1 >0) }
145 single :: BoxLabel -> Bool
146 single (ExpBox {}) = True
147 single (TopLevelBox _) = True
148 single (LocalBox _) = True
149 single (BinBox {}) = False
151 modInfo :: Flags -> Bool -> (String,[Integer]) -> IO ModInfo
152 modInfo hpcflags qualDecList (moduleName,tickCounts) = do
153 Mix _ _ _ _ mes <- readMix (hpcDirs hpcflags) moduleName
154 return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
156 q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
159 modReport :: Flags -> (String,[Integer]) -> IO ()
160 modReport hpcflags (moduleName,tickCounts) = do
161 mi <- modInfo hpcflags False (moduleName,tickCounts)
162 if xmlOutput hpcflags
163 then putStrLn $ " <module name = " ++ show moduleName ++ ">"
164 else putStrLn ("-----<module "++moduleName++">-----")
165 printModInfo hpcflags mi
166 if xmlOutput hpcflags
167 then putStrLn $ " </module>"
170 printModInfo :: Flags -> ModInfo -> IO ()
171 printModInfo hpcflags mi | xmlOutput hpcflags = do
172 element "exprs" (xmlBT $ exp mi)
173 element "booleans" (xmlBBT $ allBinCounts mi)
174 element "guards" (xmlBBT $ guard mi)
175 element "conditionals" (xmlBBT $ cond mi)
176 element "qualifiers" (xmlBBT $ qual mi)
177 element "alts" (xmlBT $ alt mi)
178 element "local" (xmlBT $ loc mi)
179 element "toplevel" (xmlBT $ top mi)
180 printModInfo hpcflags mi = do
181 putStrLn (btPercentage "expressions used" (exp mi))
182 putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi))
183 putStrLn (" "++bbtPercentage "guards" True (guard mi))
184 putStrLn (" "++bbtPercentage "'if' conditions" True (cond mi))
185 putStrLn (" "++bbtPercentage "qualifiers" True (qual mi))
186 putStrLn (btPercentage "alternatives used" (alt mi))
187 putStrLn (btPercentage "local declarations used" (loc mi))
188 putStrLn (btPercentage "top-level declarations used" (top mi))
189 modDecList hpcflags mi
191 modDecList :: Flags -> ModInfo -> IO ()
192 modDecList hpcflags mi0 =
193 when (decList hpcflags && someDecsUnused mi0) $ do
194 putStrLn "unused declarations:"
195 mapM_ showDecPath (sort (decPaths mi0))
197 someDecsUnused mi = tixCount (top mi) < boxCount (top mi) ||
198 tixCount (loc mi) < boxCount (loc mi)
199 showDecPath dp = putStrLn (" "++
200 concat (intersperse "." dp))
202 report_plugin = Plugin { name = "report"
203 , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
204 , options = report_options
205 , summary = "Output textual report about program coverage"
206 , implementation = report_main
207 , init_flags = default_flags
208 , final_flags = default_final_flags
211 report_main :: Flags -> [String] -> IO ()
212 report_main hpcflags (progName:mods) = do
213 let hpcflags1 = hpcflags
214 { includeMods = Set.fromList mods
216 includeMods hpcflags }
217 let prog = getTixFileName $ progName
220 Just (Tix tickCounts) ->
221 makeReport hpcflags1 progName
223 | TixModule m _h _ tcs <- tickCounts
224 , allowModule hpcflags1 m
226 Nothing -> error $ "unable to find tix file for:" ++ progName
230 makeReport :: Flags -> String -> [(String,[Integer])] -> IO ()
231 makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
232 putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
233 putStrLn $ "<coverage name=" ++ show progName ++ ">"
234 if perModule hpcflags
235 then mapM_ (modReport hpcflags) (sort modTcs)
237 mis <- mapM (modInfo hpcflags True) modTcs
238 putStrLn $ " <summary>"
239 printModInfo hpcflags (foldr miPlus miZero mis)
240 putStrLn $ " </summary>"
241 putStrLn $ "</coverage>"
242 makeReport hpcflags _ modTcs =
243 if perModule hpcflags then
244 mapM_ (modReport hpcflags) (sort modTcs)
246 mis <- mapM (modInfo hpcflags True) modTcs
247 printModInfo hpcflags (foldr miPlus miZero mis)
249 element :: String -> [(String,String)] -> IO ()
250 element tag attrs = putStrLn $
252 ++ unwords [ x ++ "=" ++ show y
256 xmlBT (BT b t) = [("boxes",show b),("count",show t)]
258 xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]
260 ------------------------------------------------------------------------------
262 report_options = [perModuleOpt,decListOpt,excludeOpt,includeOpt,hpcDirOpt,xmlOutputOpt]