98e418172b64eb56792a448a2f7444384276fb8a
[ghc.git] / utils / hpc / HpcReport.hs
1 ---------------------------------------------------------
2 -- The main program for the hpc-report tool, part of HPC.
3 -- Colin Runciman and Andy Gill, June 2006
4 ---------------------------------------------------------
5
6 module HpcReport (report_plugin) where
7
8 import System.Exit
9 import Prelude hiding (exp)
10 import System(getArgs)
11 import List(sort,intersperse,sortBy)
12 import HpcFlags
13 import Trace.Hpc.Mix
14 import Trace.Hpc.Tix
15 import Control.Monad hiding (guard)
16 import qualified HpcSet as Set
17
18 notExpecting :: String -> a
19 notExpecting s = error ("not expecting "++s)
20
21 data BoxTixCounts = BT {boxCount, tixCount :: !Int}
22
23 btZero :: BoxTixCounts
24 btZero = BT {boxCount=0, tixCount=0}
25
26 btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts
27 btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2)
28
29 btPercentage :: String -> BoxTixCounts -> String
30 btPercentage s (BT b t) = showPercentage s t b
31
32 showPercentage :: String -> Int -> Int -> String
33 showPercentage s 0 0 = "100% "++s++" (0/0)"
34 showPercentage s n d = showWidth 3 p++"% "++
35 s++
36 " ("++show n++"/"++show d++")"
37 where
38 p = (n*100) `div` d
39 showWidth w x0 = replicate (shortOf w (length sx)) ' ' ++ sx
40 where
41 sx = show x0
42 shortOf x y = if y < x then x-y else 0
43
44 data BinBoxTixCounts = BBT { binBoxCount
45 , onlyTrueTixCount
46 , onlyFalseTixCount
47 , bothTixCount :: !Int}
48
49 bbtzero :: BinBoxTixCounts
50 bbtzero = BBT { binBoxCount=0
51 , onlyTrueTixCount=0
52 , onlyFalseTixCount=0
53 , bothTixCount=0}
54
55 bbtPlus :: BinBoxTixCounts -> BinBoxTixCounts -> BinBoxTixCounts
56 bbtPlus (BBT b1 tt1 ft1 bt1) (BBT b2 tt2 ft2 bt2) =
57 BBT (b1+b2) (tt1+tt2) (ft1+ft2) (bt1+bt2)
58
59 bbtPercentage :: String -> Bool -> BinBoxTixCounts -> String
60 bbtPercentage s withdetail (BBT b tt ft bt) =
61 showPercentage s bt b ++
62 if withdetail && bt/=b then
63 detailFor tt "always True"++
64 detailFor ft "always False"++
65 detailFor (b-(tt+ft+bt)) "unevaluated"
66 else ""
67 where
68 detailFor n txt = if n>0 then ", "++show n++" "++txt
69 else ""
70
71 data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts
72 , guard,cond,qual :: !BinBoxTixCounts
73 , decPaths :: [[String]]}
74
75 miZero :: ModInfo
76 miZero = MI { exp=btZero
77 , alt=btZero
78 , top=btZero
79 , loc=btZero
80 , guard=bbtzero
81 , cond=bbtzero
82 , qual=bbtzero
83 , decPaths = []}
84
85 miPlus :: ModInfo -> ModInfo -> ModInfo
86 miPlus mi1 mi2 =
87 MI { exp = exp mi1 `btPlus` exp mi2
88 , alt = alt mi1 `btPlus` alt mi2
89 , top = top mi1 `btPlus` top mi2
90 , loc = loc mi1 `btPlus` loc mi2
91 , guard = guard mi1 `bbtPlus` guard mi2
92 , cond = cond mi1 `bbtPlus` cond mi2
93 , qual = qual mi1 `bbtPlus` qual mi2
94 , decPaths = decPaths mi1 ++ decPaths mi2 }
95
96 allBinCounts :: ModInfo -> BinBoxTixCounts
97 allBinCounts mi =
98 BBT { binBoxCount = sumAll binBoxCount
99 , onlyTrueTixCount = sumAll onlyTrueTixCount
100 , onlyFalseTixCount = sumAll onlyFalseTixCount
101 , bothTixCount = sumAll bothTixCount }
102 where
103 sumAll f = f (guard mi) + f (cond mi) + f (qual mi)
104
105 accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo
106 accumCounts [] mi = mi
107 accumCounts ((bl,btc):etc) mi | single bl =
108 accumCounts etc mi'
109 where
110 mi' = case bl of
111 ExpBox False -> mi{exp = inc (exp mi)}
112 ExpBox True -> mi{exp = inc (exp mi), alt = inc (alt mi)}
113 TopLevelBox dp -> mi{top = inc (top mi)
114 ,decPaths = upd dp (decPaths mi)}
115 LocalBox dp -> mi{loc = inc (loc mi)
116 ,decPaths = upd dp (decPaths mi)}
117 _other -> notExpecting "BoxLabel in accumcounts"
118 inc (BT {boxCount=bc,tixCount=tc}) =
119 BT { boxCount = bc+1
120 , tixCount = tc + bit (btc>0) }
121 upd dp dps =
122 if btc>0 then dps else dp:dps
123 accumCounts ((bl0,btc0):(bl1,btc1):etc) mi =
124 accumCounts etc mi'
125 where
126 mi' = case (bl0,bl1) of
127 (BinBox GuardBinBox True, BinBox GuardBinBox False) ->
128 mi{guard = inc (guard mi)}
129 (BinBox CondBinBox True, BinBox CondBinBox False) ->
130 mi{cond = inc (cond mi)}
131 (BinBox QualBinBox True, BinBox QualBinBox False) ->
132 mi{qual = inc (qual mi)}
133 _other -> notExpecting "BoxLabel pair in accumcounts"
134 inc (BBT { binBoxCount=bbc
135 , onlyTrueTixCount=ttc
136 , onlyFalseTixCount=ftc
137 , bothTixCount=btc}) =
138 BBT { binBoxCount = bbc+1
139 , onlyTrueTixCount = ttc + bit (btc0 >0 && btc1==0)
140 , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0)
141 , bothTixCount = btc + bit (btc0 >0 && btc1 >0) }
142
143 bit :: Bool -> Int
144 bit True = 1
145 bit False = 0
146
147 single :: BoxLabel -> Bool
148 single (ExpBox {}) = True
149 single (TopLevelBox _) = True
150 single (LocalBox _) = True
151 single (BinBox {}) = False
152
153 modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
154 modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do
155 Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix)
156 return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
157 where
158 q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
159 else mi
160
161 modReport :: Flags -> TixModule -> IO ()
162 modReport hpcflags tix@(TixModule moduleName _ _ tickCounts) = do
163 mi <- modInfo hpcflags False tix
164 if xmlOutput hpcflags
165 then putStrLn $ " <module name = " ++ show moduleName ++ ">"
166 else putStrLn ("-----<module "++moduleName++">-----")
167 printModInfo hpcflags mi
168 if xmlOutput hpcflags
169 then putStrLn $ " </module>"
170 else return ()
171
172 printModInfo :: Flags -> ModInfo -> IO ()
173 printModInfo hpcflags mi | xmlOutput hpcflags = do
174 element "exprs" (xmlBT $ exp mi)
175 element "booleans" (xmlBBT $ allBinCounts mi)
176 element "guards" (xmlBBT $ guard mi)
177 element "conditionals" (xmlBBT $ cond mi)
178 element "qualifiers" (xmlBBT $ qual mi)
179 element "alts" (xmlBT $ alt mi)
180 element "local" (xmlBT $ loc mi)
181 element "toplevel" (xmlBT $ top mi)
182 printModInfo hpcflags mi = do
183 putStrLn (btPercentage "expressions used" (exp mi))
184 putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi))
185 putStrLn (" "++bbtPercentage "guards" True (guard mi))
186 putStrLn (" "++bbtPercentage "'if' conditions" True (cond mi))
187 putStrLn (" "++bbtPercentage "qualifiers" True (qual mi))
188 putStrLn (btPercentage "alternatives used" (alt mi))
189 putStrLn (btPercentage "local declarations used" (loc mi))
190 putStrLn (btPercentage "top-level declarations used" (top mi))
191 modDecList hpcflags mi
192
193 modDecList :: Flags -> ModInfo -> IO ()
194 modDecList hpcflags mi0 =
195 when (decList hpcflags && someDecsUnused mi0) $ do
196 putStrLn "unused declarations:"
197 mapM_ showDecPath (sort (decPaths mi0))
198 where
199 someDecsUnused mi = tixCount (top mi) < boxCount (top mi) ||
200 tixCount (loc mi) < boxCount (loc mi)
201 showDecPath dp = putStrLn (" "++
202 concat (intersperse "." dp))
203
204 report_plugin = Plugin { name = "report"
205 , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
206 , options = report_options
207 , summary = "Output textual report about program coverage"
208 , implementation = report_main
209 , init_flags = default_flags
210 , final_flags = default_final_flags
211 }
212
213 report_main :: Flags -> [String] -> IO ()
214 report_main hpcflags (progName:mods) = do
215 let hpcflags1 = hpcflags
216 { includeMods = Set.fromList mods
217 `Set.union`
218 includeMods hpcflags }
219 let prog = getTixFileName $ progName
220 tix <- readTix prog
221 case tix of
222 Just (Tix tickCounts) ->
223 makeReport hpcflags1 progName
224 $ sortBy (\ mod1 mod2 -> tixModuleName mod1 `compare` tixModuleName mod2)
225 $ [ tix
226 | tix@(TixModule m _h _ tcs) <- tickCounts
227 , allowModule hpcflags1 m
228 ]
229 Nothing -> hpcError report_plugin $ "unable to find tix file for:" ++ progName
230 report_main hpcflags [] =
231 hpcError report_plugin $ "no .tix file or executable name specified"
232
233 makeReport :: Flags -> String -> [TixModule] -> IO ()
234 makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
235 putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
236 putStrLn $ "<coverage name=" ++ show progName ++ ">"
237 if perModule hpcflags
238 then mapM_ (modReport hpcflags) modTcs
239 else return ()
240 mis <- mapM (modInfo hpcflags True) modTcs
241 putStrLn $ " <summary>"
242 printModInfo hpcflags (foldr miPlus miZero mis)
243 putStrLn $ " </summary>"
244 putStrLn $ "</coverage>"
245 makeReport hpcflags _ modTcs =
246 if perModule hpcflags then
247 mapM_ (modReport hpcflags) modTcs
248 else do
249 mis <- mapM (modInfo hpcflags True) modTcs
250 printModInfo hpcflags (foldr miPlus miZero mis)
251
252 element :: String -> [(String,String)] -> IO ()
253 element tag attrs = putStrLn $
254 " <" ++ tag ++ " "
255 ++ unwords [ x ++ "=" ++ show y
256 | (x,y) <- attrs
257 ] ++ "/>"
258
259 xmlBT (BT b t) = [("boxes",show b),("count",show t)]
260
261 xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]
262
263 ------------------------------------------------------------------------------
264
265 report_options
266 = perModuleOpt
267 . decListOpt
268 . excludeOpt
269 . includeOpt
270 . srcDirOpt
271 . hpcDirOpt
272 . xmlOutputOpt
273
274