Commit 11d36d9f authored by andy@galois.com's avatar andy@galois.com
Browse files

Adding hpc tools, as a single program.

parent 147c8d2e
-- (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 = "[<HPC_COMMAND>]"
, 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
---------------------------------------------------------
-- 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] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
, 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)
-- (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]
]
---------------------------------------------------------
-- 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] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
, 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") $
"<html>" ++
"<style type=\"text/css\">" ++
"table.bar { background-color: #f25913; }\n" ++
"td.bar { background-color: #60de51; }\n" ++
"table.dashboard { border-collapse: collapse ; border: solid 1px black }\n" ++
".dashboard td { border: solid 1px black }\n" ++
".dashboard th { border: solid 1px black }\n" ++
"</style>\n" ++
"<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
"<tr>" ++
"<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
"<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
"<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
"<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
"</tr>" ++
"<tr>" ++
"<th>%</th>" ++
"<th colspan=2>covered / total</th>" ++
"<th>%</th>" ++
"<th colspan=2>covered / total</th>" ++
"<th>%</th>" ++
"<th colspan=2>covered / total</th>" ++
"</tr>" ++
concat [ showModuleSummary (modName,fileName,summary)
| (modName,fileName,summary) <- mods'
] ++
"<tr></tr>" ++
showTotalSummary (foldr1 combineSummary
[ summary
| (_,_,summary) <- mods'
])
++ "</table></html>\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 = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs
let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
let fileName = modName0 ++ ".hs.html"
putStrLn $ "Writing: " ++ fileName
writeFile (dest_dir ++ "/" ++ fileName) $
unlines [ "<html><style type=\"text/css\">",
"span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",