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 <- readMix (hpcDirs 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 -> error $ "unable to find tix file for:" ++ progName
 229
 230
 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 = [perModuleOpt,decListOpt,excludeOpt,includeOpt,hpcDirOpt,xmlOutputOpt]
 265