--- /dev/null
+-- (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
--- /dev/null
+---------------------------------------------------------
+-- 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)
+
--- /dev/null
+-- (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]
+ ]
--- /dev/null
+---------------------------------------------------------
+-- 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 }",
+ if invertOutput
+ then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
+ else "span.nottickedoff { background: " ++ yellow ++ "}",
+ if invertOutput
+ then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
+ else "span.istickedoff { background: white }",
+ "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
+ "span.tickonlytrue { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
+ "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
+ if invertOutput
+ then "span.decl { font-weight: bold; background: #d0c0ff }"
+ else "span.decl { font-weight: bold }",
+ "span.spaces { background: white }",
+ "</style>",
+ "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\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 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
+ 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 = "<span class=\"nottickedoff\">"
+openTick IsTicked = "<span class=\"istickedoff\">"
+openTick TickedOnlyTrue = "<span class=\"tickonlytrue\">"
+openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
+openTick (TopLevelDecl False _) = openTopDecl
+openTick (TopLevelDecl True 0)
+ = "<span class=\"funcount\">-- never entered</span>" ++
+ openTopDecl
+openTick (TopLevelDecl True 1)
+ = "<span class=\"funcount\">-- entered once</span>" ++
+ openTopDecl
+openTick (TopLevelDecl True n0)
+ = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ 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 = "</span>"
+
+openTopDecl :: String
+openTopDecl = "<span class=\"decl\">"
+
+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) =
+ "<tr>\n" ++
+ "<td> <tt>module <a href=\"" ++ fileName ++ "\">"
+ ++ modName ++ "</a></tt></td>\n" ++
+ showSummary (topFunTicked summary) (topFunTotal summary) ++
+ showSummary (altTicked summary) (altTotal summary) ++
+ showSummary (expTicked summary) (expTotal summary) ++
+ "</tr>\n"
+
+showTotalSummary :: ModuleSummary -> String
+showTotalSummary summary =
+ "<tr style=\"background: #e0e0e0\">\n" ++
+ "<th align=left> Program Coverage Total</tt></th>\n" ++
+ showSummary (topFunTicked summary) (topFunTotal summary) ++
+ showSummary (altTicked summary) (altTotal summary) ++
+ showSummary (expTicked summary) (expTotal summary) ++
+ "</tr>\n"
+
+showSummary :: (Integral t) => t -> t -> String
+showSummary ticked total =
+ "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
+ "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
+ "<td width=100>" ++
+ (case percent ticked total of
+ Nothing -> " "
+ Just w -> "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
+ "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
+ "<tr><td height=12 class=\"bar\"></td></tr>" ++
+ "</table></td></tr></table>")
+ ++ "</td>"
+ 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)
--- /dev/null
+---------------------------------------------------------
+-- 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 $ " <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))
+
+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
+ [(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 $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ putStrLn $ "<coverage name=" ++ show progName ++ ">"
+ if perModule hpcflags
+ then mapM_ (modReport hpcflags) (sort modTcs)
+ 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
+ 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]
+
--- /dev/null
+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
projects / ghc-hetmet.git / commitdiff