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