1---------------------------------------------------------
2-- The main program for the hpc-report tool, part of HPC.
3-- Colin Runciman and Andy Gill, June 2006
4---------------------------------------------------------
5
6module HpcReport (report_plugin) where
7
8import Prelude hiding (exp)
9import Data.List(sort,intersperse,sortBy)
10import HpcFlags
11import Trace.Hpc.Mix
12import Trace.Hpc.Tix
13import Control.Monad hiding (guard)
14import qualified Data.Set as Set
15
16notExpecting :: String -> a
17notExpecting s = error ("not expecting "++s)
18
19data BoxTixCounts = BT {boxCount, tixCount :: !Int}
20
21btZero :: BoxTixCounts
22btZero = BT {boxCount=0, tixCount=0}
23
24btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts
25btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2)
26
27btPercentage :: String -> BoxTixCounts -> String
28btPercentage s (BT b t) = showPercentage s t b
29
30showPercentage :: String -> Int -> Int -> String
31showPercentage s 0 0 = "100% "++s++" (0/0)"
32showPercentage 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
42data BinBoxTixCounts = BBT { binBoxCount
43                           , onlyTrueTixCount
44                           , onlyFalseTixCount
45                           , bothTixCount :: !Int}
46
47bbtzero :: BinBoxTixCounts
48bbtzero = BBT { binBoxCount=0
49              , onlyTrueTixCount=0
50              , onlyFalseTixCount=0
51              , bothTixCount=0}
52
53bbtPlus :: BinBoxTixCounts -> BinBoxTixCounts -> BinBoxTixCounts
54bbtPlus (BBT b1 tt1 ft1 bt1) (BBT b2 tt2 ft2 bt2) =
55  BBT (b1+b2) (tt1+tt2) (ft1+ft2) (bt1+bt2)
56
57bbtPercentage :: String -> Bool -> BinBoxTixCounts -> String
58bbtPercentage 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
69data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts
70                  , guard,cond,qual :: !BinBoxTixCounts
71                  , decPaths :: [[String]]}
72
73miZero :: ModInfo
74miZero = MI { exp=btZero
75            , alt=btZero
76            , top=btZero
77            , loc=btZero
78            , guard=bbtzero
79            , cond=bbtzero
80            , qual=bbtzero
81            , decPaths = []}
82
83miPlus :: ModInfo -> ModInfo -> ModInfo
84miPlus 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
94allBinCounts :: ModInfo -> BinBoxTixCounts
95allBinCounts 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
103accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo
104accumCounts [] mi = mi
105accumCounts ((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
121accumCounts [_] _ = error "accumCounts: Unhandled case: [_] _"
122accumCounts ((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
142bit :: Bool -> Int
143bit True = 1
144bit False = 0
145
146single :: BoxLabel -> Bool
147single (ExpBox {}) = True
148single (TopLevelBox _) = True
149single (LocalBox _) = True
150single (BinBox {}) = False
151
152modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
153modInfo 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
160modReport :: Flags -> TixModule -> IO ()
161modReport 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
171printModInfo :: Flags -> ModInfo -> IO ()
172printModInfo 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)
181printModInfo 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
192modDecList :: Flags -> ModInfo -> IO ()
193modDecList 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
203report_plugin :: Plugin
204report_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
213report_main :: Flags -> [String] -> IO ()
214report_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
230report_main _ [] =
231        hpcError report_plugin $ "no .tix file or executable name specified"
232
233makeReport :: Flags -> String -> [TixModule] -> IO ()
234makeReport 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>"
245makeReport 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
252element :: String -> [(String,String)] -> IO ()
253element tag attrs = putStrLn $
254                    "    <" ++ tag ++ " "
255                        ++ unwords [ x ++ "=" ++ show y
256                                   | (x,y) <- attrs
257                                   ] ++ "/>"
258
259xmlBT :: BoxTixCounts -> [(String, String)]
260xmlBT (BT b t) = [("boxes",show b),("count",show t)]
261
262xmlBBT :: BinBoxTixCounts -> [(String, String)]
263xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]
264
265------------------------------------------------------------------------------
266
267report_options :: FlagOptSeq
268report_options
269        = perModuleOpt
270        . decListOpt
271        . excludeOpt
272        . includeOpt
273        . srcDirOpt
274        . hpcDirOpt
275        . resetHpcDirsOpt
276        . xmlOutputOpt
277        . verbosityOpt
278
279
280