2950cbf253a6b37705a36da2e44dfb45c27047fc
[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)
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 -> (String,[Integer]) -> IO ModInfo
154 modInfo hpcflags qualDecList (moduleName,tickCounts) = do
155 Mix _ _ _ _ mes <- readMixWithFlags hpcflags moduleName
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 -> (String,[Integer]) -> IO ()
162 modReport hpcflags (moduleName,tickCounts) = do
163 mi <- modInfo hpcflags False (moduleName,tickCounts)
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 [(m,tcs)
225 | TixModule m _h _ tcs <- tickCounts
226 , allowModule hpcflags1 m
227 ]
228 Nothing -> hpcError report_plugin $ "unable to find tix file for:" ++ progName
229 report_main hpcflags [] =
230 hpcError report_plugin $ "no .tix file or executable name specified"
231
232 makeReport :: Flags -> String -> [(String,[Integer])] -> IO ()
233 makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
234 putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
235 putStrLn $ "<coverage name=" ++ show progName ++ ">"
236 if perModule hpcflags
237 then mapM_ (modReport hpcflags) (sort modTcs)
238 else return ()
239 mis <- mapM (modInfo hpcflags True) modTcs
240 putStrLn $ " <summary>"
241 printModInfo hpcflags (foldr miPlus miZero mis)
242 putStrLn $ " </summary>"
243 putStrLn $ "</coverage>"
244 makeReport hpcflags _ modTcs =
245 if perModule hpcflags then
246 mapM_ (modReport hpcflags) (sort modTcs)
247 else do
248 mis <- mapM (modInfo hpcflags True) modTcs
249 printModInfo hpcflags (foldr miPlus miZero mis)
250
251 element :: String -> [(String,String)] -> IO ()
252 element tag attrs = putStrLn $
253 " <" ++ tag ++ " "
254 ++ unwords [ x ++ "=" ++ show y
255 | (x,y) <- attrs
256 ] ++ "/>"
257
258 xmlBT (BT b t) = [("boxes",show b),("count",show t)]
259
260 xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]
261
262 ------------------------------------------------------------------------------
263
264 report_options
265 = perModuleOpt
266 . decListOpt
267 . excludeOpt
268 . includeOpt
269 . srcDirOpt
270 . hpcDirOpt
271 . xmlOutputOpt
272
273