Fix build following haskell98 and -fglasgow-exts changes
[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 Prelude hiding (exp)
9 import Data.List(sort,intersperse,sortBy)
10 import HpcFlags
11 import Trace.Hpc.Mix
12 import Trace.Hpc.Tix
13 import Control.Monad hiding (guard)
14 import qualified HpcSet as Set
15
16 notExpecting :: String -> a
17 notExpecting s = error ("not expecting "++s)
18
19 data BoxTixCounts = BT {boxCount, tixCount :: !Int}
20
21 btZero :: BoxTixCounts
22 btZero = BT {boxCount=0, tixCount=0}
23
24 btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts
25 btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2)
26
27 btPercentage :: String -> BoxTixCounts -> String
28 btPercentage s (BT b t) = showPercentage s t b
29
30 showPercentage :: String -> Int -> Int -> String
31 showPercentage s 0 0 = "100% "++s++" (0/0)"
32 showPercentage s n d = showWidth 3 p++"% "++
33 s++
34 " ("++show n++"/"++show d++")"
35 where
36 p = (n*100) `div` d
37 showWidth w x0 = replicate (shortOf w (length sx)) ' ' ++ sx
38 where
39 sx = show x0
40 shortOf x y = if y < x then x-y else 0
41
42 data BinBoxTixCounts = BBT { binBoxCount
43 , onlyTrueTixCount
44 , onlyFalseTixCount
45 , bothTixCount :: !Int}
46
47 bbtzero :: BinBoxTixCounts
48 bbtzero = BBT { binBoxCount=0
49 , onlyTrueTixCount=0
50 , onlyFalseTixCount=0
51 , bothTixCount=0}
52
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)
56
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"
64 else ""
65 where
66 detailFor n txt = if n>0 then ", "++show n++" "++txt
67 else ""
68
69 data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts
70 , guard,cond,qual :: !BinBoxTixCounts
71 , decPaths :: [[String]]}
72
73 miZero :: ModInfo
74 miZero = MI { exp=btZero
75 , alt=btZero
76 , top=btZero
77 , loc=btZero
78 , guard=bbtzero
79 , cond=bbtzero
80 , qual=bbtzero
81 , decPaths = []}
82
83 miPlus :: ModInfo -> ModInfo -> ModInfo
84 miPlus mi1 mi2 =
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 }
93
94 allBinCounts :: ModInfo -> BinBoxTixCounts
95 allBinCounts mi =
96 BBT { binBoxCount = sumAll binBoxCount
97 , onlyTrueTixCount = sumAll onlyTrueTixCount
98 , onlyFalseTixCount = sumAll onlyFalseTixCount
99 , bothTixCount = sumAll bothTixCount }
100 where
101 sumAll f = f (guard mi) + f (cond mi) + f (qual mi)
102
103 accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo
104 accumCounts [] mi = mi
105 accumCounts ((bl,btc):etc) mi
106 | single bl = accumCounts etc mi'
107 where
108 mi' = case bl of
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}) =
117 BT { boxCount = bc+1
118 , tixCount = tc + bit (btc>0) }
119 upd dp dps =
120 if btc>0 then dps else dp:dps
121 accumCounts [_] _ = error "accumCounts: Unhandled case: [_] _"
122 accumCounts ((bl0,btc0):(bl1,btc1):etc) mi =
123 accumCounts etc mi'
124 where
125 mi' = case (bl0,bl1) of
126 (BinBox GuardBinBox True, BinBox GuardBinBox False) ->
127 mi{guard = inc (guard mi)}
128 (BinBox CondBinBox True, BinBox CondBinBox False) ->
129 mi{cond = inc (cond mi)}
130 (BinBox QualBinBox True, BinBox QualBinBox False) ->
131 mi{qual = inc (qual mi)}
132 _other -> notExpecting "BoxLabel pair in accumcounts"
133 inc (BBT { binBoxCount=bbc
134 , onlyTrueTixCount=ttc
135 , onlyFalseTixCount=ftc
136 , bothTixCount=btc}) =
137 BBT { binBoxCount = bbc+1
138 , onlyTrueTixCount = ttc + bit (btc0 >0 && btc1==0)
139 , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0)
140 , bothTixCount = btc + bit (btc0 >0 && btc1 >0) }
141
142 bit :: Bool -> Int
143 bit True = 1
144 bit False = 0
145
146 single :: BoxLabel -> Bool
147 single (ExpBox {}) = True
148 single (TopLevelBox _) = True
149 single (LocalBox _) = True
150 single (BinBox {}) = False
151
152 modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
153 modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do
154 Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix)
155 return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
156 where
157 q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
158 else mi
159
160 modReport :: Flags -> TixModule -> IO ()
161 modReport hpcflags tix@(TixModule moduleName _ _ _) = do
162 mi <- modInfo hpcflags False tix
163 if xmlOutput hpcflags
164 then putStrLn $ " <module name = " ++ show moduleName ++ ">"
165 else putStrLn ("-----<module "++moduleName++">-----")
166 printModInfo hpcflags mi
167 if xmlOutput hpcflags
168 then putStrLn $ " </module>"
169 else return ()
170
171 printModInfo :: Flags -> ModInfo -> IO ()
172 printModInfo hpcflags mi | xmlOutput hpcflags = do
173 element "exprs" (xmlBT $ exp mi)
174 element "booleans" (xmlBBT $ allBinCounts mi)
175 element "guards" (xmlBBT $ guard mi)
176 element "conditionals" (xmlBBT $ cond mi)
177 element "qualifiers" (xmlBBT $ qual mi)
178 element "alts" (xmlBT $ alt mi)
179 element "local" (xmlBT $ loc mi)
180 element "toplevel" (xmlBT $ top mi)
181 printModInfo hpcflags mi = do
182 putStrLn (btPercentage "expressions used" (exp mi))
183 putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi))
184 putStrLn (" "++bbtPercentage "guards" True (guard mi))
185 putStrLn (" "++bbtPercentage "'if' conditions" True (cond mi))
186 putStrLn (" "++bbtPercentage "qualifiers" True (qual mi))
187 putStrLn (btPercentage "alternatives used" (alt mi))
188 putStrLn (btPercentage "local declarations used" (loc mi))
189 putStrLn (btPercentage "top-level declarations used" (top mi))
190 modDecList hpcflags mi
191
192 modDecList :: Flags -> ModInfo -> IO ()
193 modDecList hpcflags mi0 =
194 when (decList hpcflags && someDecsUnused mi0) $ do
195 putStrLn "unused declarations:"
196 mapM_ showDecPath (sort (decPaths mi0))
197 where
198 someDecsUnused mi = tixCount (top mi) < boxCount (top mi) ||
199 tixCount (loc mi) < boxCount (loc mi)
200 showDecPath dp = putStrLn (" "++
201 concat (intersperse "." dp))
202
203 report_plugin :: Plugin
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 _ _ _) <- tickCounts
227 , allowModule hpcflags1 m
228 ]
229 Nothing -> hpcError report_plugin $ "unable to find tix file for:" ++ progName
230 report_main _ [] =
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 :: BoxTixCounts -> [(String, String)]
260 xmlBT (BT b t) = [("boxes",show b),("count",show t)]
261
262 xmlBBT :: BinBoxTixCounts -> [(String, String)]
263 xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]
264
265 ------------------------------------------------------------------------------
266
267 report_options :: FlagOptSeq
268 report_options
269 = perModuleOpt
270 . decListOpt
271 . excludeOpt
272 . includeOpt
273 . srcDirOpt
274 . hpcDirOpt
275 . xmlOutputOpt
276
277