HpcReport.hs 9.52 KB
Newer Older
1 2 3 4 5 6 7 8
---------------------------------------------------------
-- The main program for the hpc-report tool, part of HPC.
-- Colin Runciman and Andy Gill, June 2006
---------------------------------------------------------

module HpcReport (report_plugin) where

import Prelude hiding (exp)
9
import Data.List(sort,intersperse,sortBy)
10 11 12 13
import HpcFlags
import Trace.Hpc.Mix
import Trace.Hpc.Tix
import Control.Monad hiding (guard)
14
import qualified Data.Set as Set
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104

notExpecting :: String -> a
notExpecting s = error ("not expecting "++s)

data BoxTixCounts = BT {boxCount, tixCount :: !Int}

btZero :: BoxTixCounts
btZero = BT {boxCount=0, tixCount=0}

btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts
btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2)

btPercentage :: String -> BoxTixCounts -> String
btPercentage s (BT b t) = showPercentage s t b

showPercentage :: String -> Int -> Int -> String
showPercentage s 0 0 = "100% "++s++" (0/0)"
showPercentage s n d = showWidth 3 p++"% "++
                       s++
                       " ("++show n++"/"++show d++")"
  where
  p = (n*100) `div` d
  showWidth w x0 = replicate (shortOf w (length sx)) ' ' ++ sx
                  where
                  sx = show x0
                  shortOf x y = if y < x then x-y else 0

data BinBoxTixCounts = BBT { binBoxCount
                           , onlyTrueTixCount
                           , onlyFalseTixCount
                           , bothTixCount :: !Int}

bbtzero :: BinBoxTixCounts
bbtzero = BBT { binBoxCount=0
              , onlyTrueTixCount=0
              , onlyFalseTixCount=0
              , bothTixCount=0}

bbtPlus :: BinBoxTixCounts -> BinBoxTixCounts -> BinBoxTixCounts
bbtPlus (BBT b1 tt1 ft1 bt1) (BBT b2 tt2 ft2 bt2) =
  BBT (b1+b2) (tt1+tt2) (ft1+ft2) (bt1+bt2)

bbtPercentage :: String -> Bool -> BinBoxTixCounts -> String
bbtPercentage s withdetail (BBT b tt ft bt) = 
  showPercentage s bt b ++ 
  if withdetail && bt/=b then  
    detailFor tt "always True"++
    detailFor ft "always False"++
    detailFor (b-(tt+ft+bt)) "unevaluated"
  else ""
  where
  detailFor n txt = if n>0 then ", "++show n++" "++txt
                    else ""

data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts
                  , guard,cond,qual :: !BinBoxTixCounts
                  , decPaths :: [[String]]}

miZero :: ModInfo
miZero = MI { exp=btZero
            , alt=btZero
            , top=btZero
            , loc=btZero
            , guard=bbtzero
            , cond=bbtzero
            , qual=bbtzero
            , decPaths = []}

miPlus :: ModInfo -> ModInfo -> ModInfo
miPlus mi1 mi2 =
  MI { exp = exp mi1 `btPlus` exp mi2
     , alt = alt mi1 `btPlus` alt mi2
     , top = top mi1 `btPlus` top mi2
     , loc = loc mi1 `btPlus` loc mi2
     , guard = guard mi1 `bbtPlus` guard mi2
     , cond  = cond  mi1 `bbtPlus` cond  mi2
     , qual  = qual  mi1 `bbtPlus` qual  mi2
     , decPaths = decPaths mi1 ++ decPaths mi2 }

allBinCounts :: ModInfo -> BinBoxTixCounts
allBinCounts mi =
  BBT { binBoxCount = sumAll binBoxCount
      , onlyTrueTixCount = sumAll onlyTrueTixCount
      , onlyFalseTixCount = sumAll onlyFalseTixCount
      , bothTixCount = sumAll bothTixCount }
  where
  sumAll f = f (guard mi) + f (cond mi) + f (qual mi)

accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo
accumCounts [] mi = mi
Ian Lynagh's avatar
Ian Lynagh committed
105 106
accumCounts ((bl,btc):etc) mi
 | single bl = accumCounts etc mi'
107 108 109 110 111 112 113 114 115 116 117 118 119 120
  where
  mi' = case bl of
        ExpBox False ->   mi{exp = inc (exp mi)}
        ExpBox True  ->   mi{exp = inc (exp mi), alt = inc (alt mi)}
        TopLevelBox dp -> mi{top = inc (top mi)
                            ,decPaths = upd dp (decPaths mi)}
        LocalBox dp ->    mi{loc = inc (loc mi)
                            ,decPaths = upd dp (decPaths mi)}
        _other ->          notExpecting "BoxLabel in accumcounts"
  inc (BT {boxCount=bc,tixCount=tc}) =
    BT { boxCount = bc+1
       , tixCount = tc + bit (btc>0) }
  upd dp dps =
    if btc>0 then dps else dp:dps
Ian Lynagh's avatar
Ian Lynagh committed
121
accumCounts [_] _ = error "accumCounts: Unhandled case: [_] _"
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
accumCounts ((bl0,btc0):(bl1,btc1):etc) mi =
  accumCounts etc mi'
  where
  mi' = case (bl0,bl1) of
        (BinBox GuardBinBox True, BinBox GuardBinBox False) ->
          mi{guard = inc (guard mi)}
        (BinBox CondBinBox True, BinBox CondBinBox False) ->
          mi{cond = inc (cond mi)}
        (BinBox QualBinBox True, BinBox QualBinBox False) ->
          mi{qual = inc (qual mi)}
        _other -> notExpecting "BoxLabel pair in accumcounts"
  inc (BBT { binBoxCount=bbc
           , onlyTrueTixCount=ttc
           , onlyFalseTixCount=ftc
           , bothTixCount=btc}) =
    BBT { binBoxCount       = bbc+1
        , onlyTrueTixCount  = ttc + bit (btc0 >0 && btc1==0)
        , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0)
        , bothTixCount      = btc + bit (btc0 >0 && btc1 >0) }

bit :: Bool -> Int
bit True = 1
bit False = 0

single :: BoxLabel -> Bool
single (ExpBox {}) = True
single (TopLevelBox _) = True
single (LocalBox _) = True
single (BinBox {}) = False

152 153
modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do
andy@galois.com's avatar
andy@galois.com committed
154
  Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix)
155 156 157 158 159
  return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
  where
  q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
         else mi

160
modReport :: Flags -> TixModule -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
161
modReport hpcflags tix@(TixModule moduleName _ _ _) = do
162
  mi <- modInfo hpcflags False tix
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
  if xmlOutput hpcflags 
    then putStrLn $ "  <module name = " ++ show moduleName  ++ ">"
    else putStrLn ("-----<module "++moduleName++">-----")
  printModInfo hpcflags mi
  if xmlOutput hpcflags 
    then putStrLn $ "  </module>"
    else return ()

printModInfo :: Flags -> ModInfo -> IO ()
printModInfo hpcflags mi | xmlOutput hpcflags = do
  element "exprs" (xmlBT $ exp mi)
  element "booleans" (xmlBBT $ allBinCounts mi)
  element "guards" (xmlBBT $ guard mi)
  element "conditionals" (xmlBBT $ cond mi)
  element "qualifiers" (xmlBBT $ qual mi)
  element "alts" (xmlBT $ alt mi)
  element "local" (xmlBT $ loc mi)
  element "toplevel" (xmlBT $ top mi)
printModInfo hpcflags mi = do
  putStrLn (btPercentage "expressions used" (exp mi))
  putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi))
  putStrLn ("     "++bbtPercentage "guards" True (guard mi))
  putStrLn ("     "++bbtPercentage "'if' conditions" True (cond mi))
  putStrLn ("     "++bbtPercentage "qualifiers" True (qual mi))
  putStrLn (btPercentage "alternatives used" (alt mi))
  putStrLn (btPercentage "local declarations used" (loc mi))
  putStrLn (btPercentage "top-level declarations used" (top mi))
  modDecList hpcflags mi

modDecList :: Flags -> ModInfo -> IO ()
modDecList hpcflags mi0 =
  when (decList hpcflags && someDecsUnused mi0) $ do
    putStrLn "unused declarations:"
    mapM_ showDecPath (sort (decPaths mi0))   
  where
  someDecsUnused mi = tixCount (top mi) < boxCount (top mi) ||
                      tixCount (loc mi) < boxCount (loc mi)
  showDecPath dp = putStrLn ("     "++
                             concat (intersperse "." dp))

Ian Lynagh's avatar
Ian Lynagh committed
203
report_plugin :: Plugin
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
report_plugin = Plugin { name = "report"
	      	       , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" 
		       , options = report_options 
		       , summary = "Output textual report about program coverage"
		       , implementation = report_main
		       , init_flags = default_flags
		       , final_flags = default_final_flags
		       }

report_main :: Flags -> [String] -> IO ()
report_main hpcflags (progName:mods) = do
  let hpcflags1 = hpcflags 
      		{ includeMods = Set.fromList mods 
  	      	     	 	   `Set.union` 
				includeMods hpcflags }
  let prog = getTixFileName $ progName 
  tix <- readTix prog  
  case tix of
    Just (Tix tickCounts) ->
    	   makeReport hpcflags1 progName 
224
		    $ sortBy (\ mod1 mod2 -> tixModuleName mod1 `compare` tixModuleName mod2)
Ian Lynagh's avatar
Ian Lynagh committed
225 226
	   	    $ [ tix'
	   	      | tix'@(TixModule m _ _ _) <- tickCounts
227 228
		      , allowModule hpcflags1 m 
		      ]
229
    Nothing -> hpcError report_plugin  $ "unable to find tix file for:" ++ progName
Ian Lynagh's avatar
Ian Lynagh committed
230
report_main _ [] = 
231
        hpcError report_plugin $ "no .tix file or executable name specified" 
232

233
makeReport :: Flags -> String -> [TixModule] -> IO ()
234 235 236 237
makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
  putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
  putStrLn $ "<coverage name=" ++ show progName ++ ">"
  if perModule hpcflags 
238
    then mapM_ (modReport hpcflags) modTcs
239 240 241 242 243 244 245 246
    else return ()
  mis <- mapM (modInfo hpcflags True) modTcs
  putStrLn $ "  <summary>"
  printModInfo hpcflags (foldr miPlus miZero mis)
  putStrLn $ "  </summary>"
  putStrLn $ "</coverage>"
makeReport hpcflags _ modTcs =
  if perModule hpcflags then
247
    mapM_ (modReport hpcflags) modTcs
248 249 250 251 252 253 254 255 256 257 258
  else do
    mis <- mapM (modInfo hpcflags True) modTcs
    printModInfo hpcflags (foldr miPlus miZero mis)

element :: String -> [(String,String)] -> IO ()
element tag attrs = putStrLn $ 
	    	    "    <" ++ tag ++ " " 
	    	        ++ unwords [ x ++ "=" ++ show y 
			   	   | (x,y) <- attrs
				   ] ++ "/>"

Ian Lynagh's avatar
Ian Lynagh committed
259
xmlBT :: BoxTixCounts -> [(String, String)]
260 261
xmlBT (BT b t) = [("boxes",show b),("count",show t)]

Ian Lynagh's avatar
Ian Lynagh committed
262
xmlBBT :: BinBoxTixCounts -> [(String, String)]
263 264 265 266
xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]

------------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
267
report_options :: FlagOptSeq
268 269 270 271 272 273 274 275 276
report_options 
        = perModuleOpt
        . decListOpt
        . excludeOpt
        . includeOpt
        . srcDirOpt
        . hpcDirOpt
        . xmlOutputOpt
        
277