From 11d36d9f0256a3a3ef2934a776924f7c90afb6de Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Mon, 25 Jun 2007 07:09:43 +0000 Subject: [PATCH] Adding hpc tools, as a single program. --- utils/hpc/Hpc.hs | 119 +++++++++++++ utils/hpc/HpcCombine.hs | 135 ++++++++++++++ utils/hpc/HpcFlags.hs | 149 ++++++++++++++++ utils/hpc/HpcMarkup.hs | 452 +++++++++++++++++++++++++++++++++++++++++++++++ utils/hpc/HpcReport.hs | 265 +++++++++++++++++++++++++++ utils/hpc/Makefile | 20 +++ 6 files changed, 1140 insertions(+) create mode 100644 utils/hpc/Hpc.hs create mode 100644 utils/hpc/HpcCombine.hs create mode 100644 utils/hpc/HpcFlags.hs create mode 100644 utils/hpc/HpcMarkup.hs create mode 100644 utils/hpc/HpcReport.hs create mode 100644 utils/hpc/Makefile diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs new file mode 100644 index 0000000..786323f --- /dev/null +++ b/utils/hpc/Hpc.hs @@ -0,0 +1,119 @@ +-- (c) 2007 Andy Gill + +-- Main driver for Hpc +import Trace.Hpc.Tix +import HpcFlags +import System.Environment +import System.Exit +import System.Console.GetOpt + +import HpcReport +import HpcMarkup +import HpcCombine + +helpList :: IO () +helpList = + putStrLn $ + "Usage: hpc COMMAND ...\n\n" ++ + section "Commands" help ++ + section "Reporting Coverage" reporting ++ + section "Processing Coverage files" processing ++ + section "Others" other ++ + "" + where + help = ["help"] + reporting = ["report","markup"] + processing = ["combine"] + other = [ name hook + | hook <- hooks + , name hook `notElem` + (concat [help,reporting,processing]) + ] + +section :: String -> [String] -> String +section msg [] = "" +section msg cmds = msg ++ ":\n" + ++ unlines [ take 14 (" " ++ cmd ++ repeat ' ') ++ summary hook + | cmd <- cmds + , hook <- hooks + , name hook == cmd + ] + +dispatch :: [String] -> IO () +dispatch [] = do + helpList + exitWith ExitSuccess +dispatch (txt:args) = do + case lookup txt hooks' of + Just plugin -> parse plugin + _ -> parse help_plugin + where + parse plugin = + case getOpt Permute (options plugin) args of + (_,_,errs) | not (null errs) + -> do putStrLn "hpc failed:" + sequence [ putStr (" " ++ err) + | err <- errs + ] + putStrLn $ "\n" + command_usage plugin + exitFailure + (o,ns,_) -> do + let flags = foldr (.) (final_flags plugin) o + $ init_flags plugin + implementation plugin flags ns +main = do + args <- getArgs + dispatch args + +------------------------------------------------------------------------------ + +hooks = [ help_plugin + , report_plugin + , markup_plugin + , combine_plugin + , version_plugin + ] + +hooks' = [ (name hook,hook) | hook <- hooks ] + +------------------------------------------------------------------------------ + +help_plugin = Plugin { name = "help" + , usage = "[]" + , summary = "Display help for hpc or a single command." + , options = help_options + , implementation = help_main + , init_flags = default_flags + , final_flags = default_final_flags + } + +help_main flags [] = do + helpList + exitWith ExitSuccess +help_main flags (sub_txt:_) = do + case lookup sub_txt hooks' of + Nothing -> do + putStrLn $ "no such hpc command : " ++ sub_txt + exitFailure + Just plugin' -> do + command_usage plugin' + exitWith ExitSuccess + +help_options = [] + +------------------------------------------------------------------------------ + +version_plugin = Plugin { name = "version" + , usage = "" + , summary = "Display version for hpc" + , options = [] + , implementation = version_main + , init_flags = default_flags + , final_flags = default_final_flags + } + +version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev" + + +------------------------------------------------------------------------------ \ No newline at end of file diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs new file mode 100644 index 0000000..193b03c --- /dev/null +++ b/utils/hpc/HpcCombine.hs @@ -0,0 +1,135 @@ +--------------------------------------------------------- +-- The main program for the hpc-add tool, part of HPC. +-- Andy Gill, Oct 2006 +--------------------------------------------------------- + +module HpcCombine (combine_plugin) where + +import Trace.Hpc.Tix +import Trace.Hpc.Util + +import HpcFlags + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set + +import System.Environment + +------------------------------------------------------------------------------ +combine_options = + [ excludeOpt,includeOpt,outputOpt,combineFunOpt, combineFunOptInfo, postInvertOpt ] + +combine_plugin = Plugin { name = "combine" + , usage = "[OPTION] .. [ [ ..]]" + , options = combine_options + , summary = "Combine multiple .tix files in a single .tix files" + , implementation = combine_main + , init_flags = default_flags + , final_flags = default_final_flags + } + +------------------------------------------------------------------------------ + +combine_main :: Flags -> [String] -> IO () +combine_main flags (first_file:more_files) = do + -- combine does not expand out the .tix filenames (by design). + + let f = case combineFun flags of + ADD -> \ l r -> l + r + SUB -> \ l r -> max 0 (l - r) + DIFF -> \ g b -> if g > 0 then 0 else min 1 b + ZERO -> \ _ _ -> 0 + + Just tix <- readTix first_file + + tix' <- foldM (mergeTixFile flags f) + (filterTix flags tix) + more_files + + let (Tix inside_tix') = tix' + let inv 0 = 1 + inv n = 0 + let tix'' = if postInvert flags + then Tix [ TixModule m p i (map inv t) + | TixModule m p i t <- inside_tix' + ] + else tix' + + case outputFile flags of + "-" -> putStrLn (show tix'') + out -> writeTix out tix'' + +mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix +mergeTixFile flags fn tix file_name = do + Just new_tix <- readTix file_name + return $! strict $ mergeTix fn tix (filterTix flags new_tix) + +-- could allow different numbering on the module info, +-- as long as the total is the same; will require normalization. + +mergeTix :: (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix +mergeTix f + (Tix t1) + (Tix t2) = Tix + [ case (Map.lookup m fm1,Map.lookup m fm2) of + -- todo, revisit the semantics of this combination + (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2)) + | hash1 /= hash2 + || length tix1 /= length tix2 + || len1 /= length tix1 + || len2 /= length tix2 + -> error $ "mismatched in module " ++ m + | otherwise -> + TixModule m hash1 len1 (zipWith f tix1 tix2) + (Just (TixModule _ hash1 len1 tix1),Nothing) -> + error $ "rogue module " ++ show m + (Nothing,Just (TixModule _ hash2 len2 tix2)) -> + error $ "rogue module " ++ show m + _ -> error "impossible" + | m <- Set.toList (m1s `Set.intersection` m2s) + ] + where + m1s = Set.fromList $ map tixModuleName t1 + m2s = Set.fromList $ map tixModuleName t2 + + fm1 = Map.fromList [ (tixModuleName tix,tix) + | tix <- t1 + ] + fm2 = Map.fromList [ (tixModuleName tix,tix) + | tix <- t2 + ] + + +-- What I would give for a hyperstrict :-) +-- This makes things about 100 times faster. +class Strict a where + strict :: a -> a + +instance Strict Integer where + strict i = i + +instance Strict Int where + strict i = i + +instance Strict Hash where -- should be fine, because Hash is a newtype round an Int + strict i = i + +instance Strict Char where + strict i = i + +instance Strict a => Strict [a] where + strict (a:as) = (((:) $! strict a) $! strict as) + strict [] = [] + +instance (Strict a, Strict b) => Strict (a,b) where + strict (a,b) = (((,) $! strict a) $! strict b) + +instance Strict Tix where + strict (Tix t1) = + Tix $! strict t1 + +instance Strict TixModule where + strict (TixModule m1 p1 i1 t1) = + ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1) + diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs new file mode 100644 index 0000000..cb561a6 --- /dev/null +++ b/utils/hpc/HpcFlags.hs @@ -0,0 +1,149 @@ +-- (c) 2007 Andy Gill + +module HpcFlags where + +import System.Console.GetOpt +import Data.Maybe ( fromMaybe ) +import qualified Data.Set as Set +import Data.Char +import Trace.Hpc.Tix + +data Flags = Flags + { outputFile :: String + , includeMods :: Set.Set String + , excludeMods :: Set.Set String + , hsDirs :: [String] + , hpcDirs :: [String] + , destDir :: String + + , perModule :: Bool + , decList :: Bool + , xmlOutput :: Bool + + , funTotals :: Bool + , altHighlight :: Bool + + , combineFun :: CombineFun + , postInvert :: Bool + } + +default_flags = Flags + { outputFile = "-" + , includeMods = Set.empty + , excludeMods = Set.empty + , hpcDirs = [] + , hsDirs = [] + , destDir = "." + + , perModule = False + , decList = False + , xmlOutput = False + + , funTotals = False + , altHighlight = False + + , combineFun = ADD + , postInvert = False + } + +-- We do this after reading flags, because the defaults +-- depends on if specific flags we used. + +default_final_flags flags = flags + { hpcDirs = if null (hpcDirs flags) + then [".hpc"] + else hpcDirs flags + , hsDirs = if null (hsDirs flags) + then ["."] + else hsDirs flags + } + +noArg :: String -> String -> (Flags -> Flags) -> OptDescr (Flags -> Flags) +noArg flag detail fn = Option [] [flag] (NoArg $ fn) detail + +anArg :: String -> String -> String -> (String -> Flags -> Flags) -> OptDescr (Flags -> Flags) +anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail + +infoArg :: String -> OptDescr (Flags -> Flags) +infoArg info = Option [] [] (NoArg $ id) info + +excludeOpt = anArg "exclude" "exclude MODULE" "MODULE" $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f } + +includeOpt = anArg "include" "include MODULE" "MODULE" $ \ a f -> f { includeMods = a `Set.insert` includeMods f } +hpcDirOpt = anArg "hpcdir" "path to .mix files (default .hpc)" "DIR" + $ \ a f -> f { hpcDirs = hpcDirs f ++ [a] } +hsDirOpt = anArg "hsdir" "path to .hs files (default .)" "DIR" + $ \ a f -> f { hsDirs = hsDirs f ++ [a] } +destDirOpt = anArg "destdir" "path to write output to" "DIR" + $ \ a f -> f { destDir = a } +outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a } +-- markup + +perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True } +decListOpt = noArg "dec-list" "show unused decls" $ \ f -> f { decList = True } +xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True } +funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts" + $ \ f -> f { funTotals = True } +altHighlightOpt + = noArg "highlight-covered" "highlight covered code, rather that code gaps" + $ \ f -> f { altHighlight = True } + +combineFunOpt = anArg "combine" + "combine .tix files with join function, default = ADD" "FUNCTION" + $ \ a f -> case reads (map toUpper a) of + [(c,"")] -> f { combineFun = c } + _ -> error $ "no such combine function : " ++ a +combineFunOptInfo = infoArg + $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst combineFuns) + +postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked" + $ \ f -> f { funTotals = True } +------------------------------------------------------------------------------- + +command_usage plugin = + putStrLn $ + "Usage: hpc " ++ (name plugin) ++ " " ++ + (usage plugin) ++ + if null (options plugin) + then "" + else usageInfo "\n\nOptions:\n" (options plugin) + +------------------------------------------------------------------------------- + +data Plugin = Plugin { name :: String + , usage :: String + , options :: [OptDescr (Flags -> Flags)] + , summary :: String + , implementation :: Flags -> [String] -> IO () + , init_flags :: Flags + , final_flags :: Flags -> Flags + } + +------------------------------------------------------------------------------ + +-- filterModules takes a list of candidate modules, +-- and +-- * excludes the excluded modules +-- * includes the rest if there are no explicity included modules +-- * otherwise, accepts just the included modules. + +allowModule :: Flags -> String -> Bool +allowModule flags mod + | mod `Set.member` excludeMods flags = False + | Set.null (includeMods flags) = True + | mod `Set.member` includeMods flags = True + | otherwise = False + +filterTix :: Flags -> Tix -> Tix +filterTix flags (Tix tixs) = + Tix $ filter (allowModule flags . tixModuleName) tixs + +------------------------------------------------------------------------------ +-- HpcCombine specifics + +data CombineFun = ADD | DIFF | SUB | ZERO + deriving (Eq,Show, Read, Enum) + +combineFuns = [ (show comb,comb) + | comb <- [ADD .. ZERO] + ] diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs new file mode 100644 index 0000000..53eaf32 --- /dev/null +++ b/utils/hpc/HpcMarkup.hs @@ -0,0 +1,452 @@ +--------------------------------------------------------- +-- The main program for the hpc-markup tool, part of HPC. +-- Andy Gill and Colin Runciman, June 2006 +--------------------------------------------------------- + +module HpcMarkup (markup_plugin) where + +import Trace.Hpc.Mix +import Trace.Hpc.Tix +import Trace.Hpc.Util + +import HpcFlags + +import System.Environment +import Data.List +import Data.Maybe(fromJust) +import Data.Array +import qualified Data.Set as Set + +------------------------------------------------------------------------------ + +markup_options = + [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt + , altHighlightOpt + , destDirOpt + ] + +markup_plugin = Plugin { name = "markup" + , usage = "[OPTION] .. [ [ ..]]" + , options = markup_options + , summary = "Markup Haskell source with program coverage" + , implementation = markup_main + , init_flags = default_flags + , final_flags = default_final_flags + } + +------------------------------------------------------------------------------ + +markup_main :: Flags -> [String] -> IO () +markup_main flags (prog:modNames) = do + let hpcflags1 = flags + { includeMods = Set.fromList modNames + `Set.union` + includeMods flags } + let Flags + { hpcDirs = hpcDirs + , hsDirs = theHsPath + , funTotals = theFunTotals + , altHighlight = invertOutput + , destDir = dest_dir + } = hpcflags1 + + mtix <- readTix (getTixFileName prog) + Tix tixs <- case mtix of + Nothing -> error $ "unable to find tix file for: " ++ prog + Just a -> return a + + mods <- + sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput + | tix <- tixs + , allowModule hpcflags1 (tixModuleName tix) + ] + + let index_name = "hpc_index" + index_fun = "hpc_index_fun" + index_alt = "hpc_index_alt" + index_exp = "hpc_index_exp" + + let writeSummary name cmp = do + let mods' = sortBy cmp mods + + putStrLn $ "Writing: " ++ (name ++ ".html") + writeFile (dest_dir ++ "/" ++ name ++ ".html") $ + "" ++ + "\n" ++ + "\n" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + "" ++ + concat [ showModuleSummary (modName,fileName,summary) + | (modName,fileName,summary) <- mods' + ] ++ + "" ++ + showTotalSummary (foldr1 combineSummary + [ summary + | (_,_,summary) <- mods' + ]) + ++ "
moduleTop Level DefinitionsAlternativesExpressions
%covered / total%covered / total%covered / total
\n" + + writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2 + + writeSummary index_fun $ \ (_,_,s1) (_,_,s2) -> + compare (percent (topFunTicked s2) (topFunTotal s2)) + (percent (topFunTicked s1) (topFunTotal s1)) + + writeSummary index_alt $ \ (_,_,s1) (_,_,s2) -> + compare (percent (altTicked s2) (altTotal s2)) + (percent (altTicked s1) (altTotal s1)) + + writeSummary index_exp $ \ (_,_,s1) (_,_,s2) -> + compare (percent (expTicked s2) (expTotal s2)) + (percent (expTicked s1) (expTotal s1)) + + +markup_main flags [] = error $ "no .tix file or executable name specified" + +genHtmlFromMod + :: String + -> [FilePath] + -> TixModule + -> Bool + -> [String] + -> Bool + -> IO (String, [Char], ModuleSummary) +genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do + let modName0 = tixModuleName tix + + (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0 + + let arr_tix :: Array Int Integer + arr_tix = listArray (0,length (tixModuleTixs tix) - 1) + $ tixModuleTixs tix + + let tickedWith :: Int -> Integer + tickedWith n = arr_tix ! n + + isTicked n = tickedWith n /= 0 + + let info = [ (pos,theMarkup) + | (gid,(pos,boxLabel)) <- zip [0 ..] mix' + , let binBox = case (isTicked gid,isTicked (gid+1)) of + (False,False) -> [] + (True,False) -> [TickedOnlyTrue] + (False,True) -> [TickedOnlyFalse] + (True,True) -> [] + , let tickBox = if isTicked gid + then [IsTicked] + else [NotTicked] + , theMarkup <- case boxLabel of + ExpBox {} -> tickBox + TopLevelBox {} + -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox + LocalBox {} -> tickBox + BinBox _ True -> binBox + _ -> [] + ] + + + let summary = foldr (.) id + [ \ st -> + case boxLabel of + ExpBox False + -> st { expTicked = ticked (expTicked st) + , expTotal = succ (expTotal st) + } + ExpBox True + -> st { expTicked = ticked (expTicked st) + , expTotal = succ (expTotal st) + , altTicked = ticked (altTicked st) + , altTotal = succ (altTotal st) + } + TopLevelBox _ -> + st { topFunTicked = ticked (topFunTicked st) + , topFunTotal = succ (topFunTotal st) + } + _ -> st + | (gid,(_pos,boxLabel)) <- zip [0 ..] mix' + , let ticked = if isTicked gid + then succ + else id + ] $ ModuleSummary + { expTicked = 0 + , expTotal = 0 + , topFunTicked = 0 + , topFunTotal = 0 + , altTicked = 0 + , altTotal = 0 + } + + -- add prefix to modName argument + content <- readFileFromPath origFile theHsPath + + let content' = markup tabStop info content + let show' = reverse . take 5 . (++ " ") . reverse . show + let addLine n xs = "" ++ show' n ++ " " ++ xs + let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines + let fileName = modName0 ++ ".hs.html" + putStrLn $ "Writing: " ++ fileName + writeFile (dest_dir ++ "/" ++ fileName) $ + unlines [ "", + "
"] ++ addLines content' ++ "\n
\n\n"; + + summary `seq` return (modName0,fileName,summary) + +data Loc = Loc !Int !Int + deriving (Eq,Ord,Show) + +data Markup + = NotTicked + | TickedOnlyTrue + | TickedOnlyFalse + | IsTicked + | TopLevelDecl + Bool -- display entry totals + Integer + deriving (Eq,Show) + +markup :: Int -- ^tabStop + -> [(HpcPos,Markup)] -- random list of tick location pairs + -> String -- text to mark up + -> String +markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs + where + tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark) + | (pos,mark) <- mix + , let (ln1,c1,ln2,c2) = fromHpcPos pos + ] + sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) -> + (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs + +addMarkup :: Int -- tabStop + -> String -- text to mark up + -> Loc -- current location + -> [(Loc,Markup)] -- stack of open ticks, with closing location + -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs + -> String + +-- check the pre-condition. +--addMarkup tabStop cs loc os ticks +-- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os + +--addMarkup tabStop cs loc os@(_:_) ticks +-- | trace (show (loc,os,take 10 ticks)) False = undefined + +-- close all open ticks, if we have reached the end +addMarkup _ [] _loc os [] = + concatMap (const closeTick) os +addMarkup tabStop cs loc ((o,_):os) ticks | loc > o = + closeTick ++ addMarkup tabStop cs loc os ticks + +--addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 = +-- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks + +addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 = + case os of + ((_,tik'):_) + | not (allowNesting tik0 tik') + -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool + _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks + where + + addTo (t,tik) [] = [(t,tik)] + addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs + | t > t' = (t',tik):(t',tik'):xs + +addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 = + -- throw away this tick, because it is from a previous place ?? + addMarkup tabStop0 cs loc os ticks + +addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks + | ln == ln2 && col < col2 + = addMarkup tabStop0 (' ':'\n':cs) loc os ticks +addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks = + if c0=='\n' && os/=[] then + concatMap (const closeTick) (downToTopLevel os) ++ + c0 : "" ++ expand 1 w ++ "" ++ + concatMap (openTick.snd) (reverse (downToTopLevel os)) ++ + addMarkup tabStop0 cs' loc' os ticks + else if c0=='\t' then + expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks + else + escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks + where + (w,cs') = span (`elem` " \t") cs + loc' = foldl (flip incBy) loc (c0:w) + escape '>' = ">" + escape '<' = "<" + escape '"' = """ + escape '&' = "&" + escape c = [c] + + expand :: Int -> String -> String + expand _ "" = "" + expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s + where + c' = tabStopAfter 8 c + expand c (' ':s) = ' ' : expand (c+1) s + expand _ _ = error "bad character in string for expansion" + + incBy :: Char -> Loc -> Loc + incBy '\n' (Loc ln _c) = Loc (succ ln) 1 + incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c) + incBy _ (Loc ln c) = Loc ln (succ c) + + tabStopAfter :: Int -> Int -> Int + tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..]) + + +addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks) + +openTick :: Markup -> String +openTick NotTicked = "" +openTick IsTicked = "" +openTick TickedOnlyTrue = "" +openTick TickedOnlyFalse = "" +openTick (TopLevelDecl False _) = openTopDecl +openTick (TopLevelDecl True 0) + = "-- never entered" ++ + openTopDecl +openTick (TopLevelDecl True 1) + = "-- entered once" ++ + openTopDecl +openTick (TopLevelDecl True n0) + = "-- entered " ++ showBigNum n0 ++ " times" ++ openTopDecl + where showBigNum n | n <= 9999 = show n + | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000) + showBigNum' n | n <= 999 = show n + | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000) + showWith n = take 3 $ reverse $ ("000" ++) $ reverse $ show n + +closeTick :: String +closeTick = "" + +openTopDecl :: String +openTopDecl = "" + +downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)] +downToTopLevel ((_,TopLevelDecl {}):_) = [] +downToTopLevel (o : os) = o : downToTopLevel os +downToTopLevel [] = [] + + +-- build in logic for nesting bin boxes + +allowNesting :: Markup -- innermost + -> Markup -- outermost + -> Bool +allowNesting n m | n == m = False -- no need to double nest +allowNesting IsTicked TickedOnlyFalse = False +allowNesting IsTicked TickedOnlyTrue = False +allowNesting _ _ = True + +------------------------------------------------------------------------------ + +data ModuleSummary = ModuleSummary + { expTicked :: !Int + , expTotal :: !Int + , topFunTicked :: !Int + , topFunTotal :: !Int + , altTicked :: !Int + , altTotal :: !Int + } + deriving (Show) + + +showModuleSummary :: (String, String, ModuleSummary) -> String +showModuleSummary (modName,fileName,summary) = + "\n" ++ + "  module " + ++ modName ++ "\n" ++ + showSummary (topFunTicked summary) (topFunTotal summary) ++ + showSummary (altTicked summary) (altTotal summary) ++ + showSummary (expTicked summary) (expTotal summary) ++ + "\n" + +showTotalSummary :: ModuleSummary -> String +showTotalSummary summary = + "\n" ++ + "  Program Coverage Total\n" ++ + showSummary (topFunTicked summary) (topFunTotal summary) ++ + showSummary (altTicked summary) (altTotal summary) ++ + showSummary (expTicked summary) (expTotal summary) ++ + "\n" + +showSummary :: (Integral t) => t -> t -> String +showSummary ticked total = + "" ++ showP (percent ticked total) ++ "" ++ + "" ++ show ticked ++ "/" ++ show total ++ "" ++ + "" ++ + (case percent ticked total of + Nothing -> " " + Just w -> "" ++ + "
" ++ + "" ++ + "
") + ++ "" + where + showP Nothing = "- " + showP (Just x) = show x ++ "%" + +percent :: (Integral a) => a -> a -> Maybe a +percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total) + + +combineSummary :: ModuleSummary -> ModuleSummary -> ModuleSummary +combineSummary (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1) + (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2) + = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2) + +------------------------------------------------------------------------------ +-- global color pallete + +red,green,yellow :: String +red = "#f20913" +green = "#60de51" +yellow = "yellow" + +------------------------------------------------------------------------------ + +readFileFromPath :: String -> [String] -> IO String +readFileFromPath filename@('/':_) _ = readFile filename +readFileFromPath filename path0 = readTheFile path0 + where + readTheFile :: [String] -> IO String + readTheFile [] = error $ "could not find " ++ show filename + ++ " in path " ++ show path0 + readTheFile (dir:dirs) = + catch (do str <- readFile (dir ++ "/" ++ filename) + return str) + (\ _ -> readTheFile dirs) diff --git a/utils/hpc/HpcReport.hs b/utils/hpc/HpcReport.hs new file mode 100644 index 0000000..2c502f4 --- /dev/null +++ b/utils/hpc/HpcReport.hs @@ -0,0 +1,265 @@ +--------------------------------------------------------- +-- The main program for the hpc-report tool, part of HPC. +-- Colin Runciman and Andy Gill, June 2006 +--------------------------------------------------------- + +module HpcReport (report_plugin) where + +import System.Exit +import Prelude hiding (exp) +import System(getArgs) +import List(sort,intersperse) +import HpcFlags +import Trace.Hpc.Mix +import Trace.Hpc.Tix +import Control.Monad hiding (guard) +import qualified Data.Set as Set + +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 +accumCounts ((bl,btc):etc) mi | single bl = + accumCounts etc mi' + 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 +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 + +modInfo :: Flags -> Bool -> (String,[Integer]) -> IO ModInfo +modInfo hpcflags qualDecList (moduleName,tickCounts) = do + Mix _ _ _ _ mes <- readMix (hpcDirs hpcflags) moduleName + return (q (accumCounts (zip (map snd mes) tickCounts) miZero)) + where + q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)} + else mi + +modReport :: Flags -> (String,[Integer]) -> IO () +modReport hpcflags (moduleName,tickCounts) = do + mi <- modInfo hpcflags False (moduleName,tickCounts) + if xmlOutput hpcflags + then putStrLn $ " " + else putStrLn ("----------") + printModInfo hpcflags mi + if xmlOutput hpcflags + then putStrLn $ " " + 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)) + +report_plugin = Plugin { name = "report" + , usage = "[OPTION] .. [ [ ..]]" + , 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 + [(m,tcs) + | TixModule m _h _ tcs <- tickCounts + , allowModule hpcflags1 m + ] + Nothing -> error $ "unable to find tix file for:" ++ progName + + + +makeReport :: Flags -> String -> [(String,[Integer])] -> IO () +makeReport hpcflags progName modTcs | xmlOutput hpcflags = do + putStrLn $ "" + putStrLn $ "" + if perModule hpcflags + then mapM_ (modReport hpcflags) (sort modTcs) + else return () + mis <- mapM (modInfo hpcflags True) modTcs + putStrLn $ " " + printModInfo hpcflags (foldr miPlus miZero mis) + putStrLn $ " " + putStrLn $ "" +makeReport hpcflags _ modTcs = + if perModule hpcflags then + mapM_ (modReport hpcflags) (sort modTcs) + 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 + ] ++ "/>" + +xmlBT (BT b t) = [("boxes",show b),("count",show t)] + +xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))] + +------------------------------------------------------------------------------ + +report_options = [perModuleOpt,decListOpt,excludeOpt,includeOpt,hpcDirOpt,xmlOutputOpt] + diff --git a/utils/hpc/Makefile b/utils/hpc/Makefile new file mode 100644 index 0000000..f8eb9e5 --- /dev/null +++ b/utils/hpc/Makefile @@ -0,0 +1,20 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +HS_PROG = hpc$(exeext) +INSTALL_PROGS += $(HS_PROG) +HPC_LIB = $(TOP)/libraries/hpc + +SRCS += Trace/Hpc/Mix.hs Trace/Hpc/Tix.hs Trace/Hpc/Util.hs + +# workaround till we can force hpc to be built with stage-1. +Trace/Hpc/%.hs: $(HPC_LIB)/Trace/Hpc/%.hs + mkdir -p Trace/Hpc + cp $(HPC_LIB)/$@ $@ + +binary-dist: + $(INSTALL_DIR) $(BIN_DIST_DIR)/utils/hpc + $(INSTALL_DATA) Makefile $(BIN_DIST_DIR)/utils/hpc/ + $(INSTALL_PROGRAM) $(HS_PROG) $(BIN_DIST_DIR)/utils/hpc/ + +include $(TOP)/mk/target.mk -- 1.7.10.4