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