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 List(sort,intersperse)
  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 | single bl =
 106   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 ((bl0,btc0):(bl1,btc1):etc) mi =
 122   accumCounts etc mi'
 123   where
 124   mi' = case (bl0,bl1) of
 125         (BinBox GuardBinBox True, BinBox GuardBinBox False) ->
 126           mi{guard = inc (guard mi)}
 127         (BinBox CondBinBox True, BinBox CondBinBox False) ->
 128           mi{cond = inc (cond mi)}
 129         (BinBox QualBinBox True, BinBox QualBinBox False) ->
 130           mi{qual = inc (qual mi)}
 131         _other -> notExpecting "BoxLabel pair in accumcounts"
 132   inc (BBT { binBoxCount=bbc
 133            , onlyTrueTixCount=ttc
 134            , onlyFalseTixCount=ftc
 135            , bothTixCount=btc}) =
 136     BBT { binBoxCount       = bbc+1
 137         , onlyTrueTixCount  = ttc + bit (btc0 >0 && btc1==0)
 138         , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0)
 139         , bothTixCount      = btc + bit (btc0 >0 && btc1 >0) }
 140
 141 bit :: Bool -> Int
 142 bit True = 1
 143 bit False = 0
 144
 145 single :: BoxLabel -> Bool
 146 single (ExpBox {}) = True
 147 single (TopLevelBox _) = True
 148 single (LocalBox _) = True
 149 single (BinBox {}) = False
 150
 151 modInfo :: Flags -> Bool -> (String,[Integer]) -> IO ModInfo
 152 modInfo hpcflags qualDecList (moduleName,tickCounts) = do
 153   Mix _ _ _ _ mes <- readMix (hpcDirs hpcflags) moduleName
 154   return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
 155   where
 156   q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
 157          else mi
 158
 159 modReport :: Flags -> (String,[Integer]) -> IO ()
 160 modReport hpcflags (moduleName,tickCounts) = do
 161   mi <- modInfo hpcflags False (moduleName,tickCounts)
 162   if xmlOutput hpcflags
 163     then putStrLn $ "  <module name = " ++ show moduleName  ++ ">"
 164     else putStrLn ("-----<module "++moduleName++">-----")
 165   printModInfo hpcflags mi
 166   if xmlOutput hpcflags
 167     then putStrLn $ "  </module>"
 168     else return ()
 169
 170 printModInfo :: Flags -> ModInfo -> IO ()
 171 printModInfo hpcflags mi | xmlOutput hpcflags = do
 172   element "exprs" (xmlBT $ exp mi)
 173   element "booleans" (xmlBBT $ allBinCounts mi)
 174   element "guards" (xmlBBT $ guard mi)
 175   element "conditionals" (xmlBBT $ cond mi)
 176   element "qualifiers" (xmlBBT $ qual mi)
 177   element "alts" (xmlBT $ alt mi)
 178   element "local" (xmlBT $ loc mi)
 179   element "toplevel" (xmlBT $ top mi)
 180 printModInfo hpcflags mi = do
 181   putStrLn (btPercentage "expressions used" (exp mi))
 182   putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi))
 183   putStrLn ("     "++bbtPercentage "guards" True (guard mi))
 184   putStrLn ("     "++bbtPercentage "'if' conditions" True (cond mi))
 185   putStrLn ("     "++bbtPercentage "qualifiers" True (qual mi))
 186   putStrLn (btPercentage "alternatives used" (alt mi))
 187   putStrLn (btPercentage "local declarations used" (loc mi))
 188   putStrLn (btPercentage "top-level declarations used" (top mi))
 189   modDecList hpcflags mi
 190
 191 modDecList :: Flags -> ModInfo -> IO ()
 192 modDecList hpcflags mi0 =
 193   when (decList hpcflags && someDecsUnused mi0) $ do
 194     putStrLn "unused declarations:"
 195     mapM_ showDecPath (sort (decPaths mi0))
 196   where
 197   someDecsUnused mi = tixCount (top mi) < boxCount (top mi) ||
 198                       tixCount (loc mi) < boxCount (loc mi)
 199   showDecPath dp = putStrLn ("     "++
 200                              concat (intersperse "." dp))
 201
 202 report_plugin = Plugin { name = "report"
 203                        , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
 204                        , options = report_options
 205                        , summary = "Output textual report about program coverage"
 206                        , implementation = report_main
 207                        , init_flags = default_flags
 208                        , final_flags = default_final_flags
 209                        }
 210
 211 report_main :: Flags -> [String] -> IO ()
 212 report_main hpcflags (progName:mods) = do
 213   let hpcflags1 = hpcflags
 214                 { includeMods = Set.fromList mods
 215                                    `Set.union`
 216                                 includeMods hpcflags }
 217   let prog = getTixFileName $ progName
 218   tix <- readTix prog
 219   case tix of
 220     Just (Tix tickCounts) ->
 221            makeReport hpcflags1 progName
 222                       [(m,tcs)
 223                       | TixModule m _h _ tcs <- tickCounts
 224                       , allowModule hpcflags1 m
 225                       ]
 226     Nothing -> error $ "unable to find tix file for:" ++ progName
 227
 228
 229
 230 makeReport :: Flags -> String -> [(String,[Integer])] -> IO ()
 231 makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
 232   putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
 233   putStrLn $ "<coverage name=" ++ show progName ++ ">"
 234   if perModule hpcflags
 235     then mapM_ (modReport hpcflags) (sort modTcs)
 236     else return ()
 237   mis <- mapM (modInfo hpcflags True) modTcs
 238   putStrLn $ "  <summary>"
 239   printModInfo hpcflags (foldr miPlus miZero mis)
 240   putStrLn $ "  </summary>"
 241   putStrLn $ "</coverage>"
 242 makeReport hpcflags _ modTcs =
 243   if perModule hpcflags then
 244     mapM_ (modReport hpcflags) (sort modTcs)
 245   else do
 246     mis <- mapM (modInfo hpcflags True) modTcs
 247     printModInfo hpcflags (foldr miPlus miZero mis)
 248
 249 element :: String -> [(String,String)] -> IO ()
 250 element tag attrs = putStrLn $
 251                     "    <" ++ tag ++ " "
 252                         ++ unwords [ x ++ "=" ++ show y
 253                                    | (x,y) <- attrs
 254                                    ] ++ "/>"
 255
 256 xmlBT (BT b t) = [("boxes",show b),("count",show t)]
 257
 258 xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]
 259
 260 ------------------------------------------------------------------------------
 261
 262 report_options = [perModuleOpt,decListOpt,excludeOpt,includeOpt,hpcDirOpt,xmlOutputOpt]
 263