Commit 1b82619b authored by Yuras's avatar Yuras Committed by Austin Seipp
Browse files

Add configurable verbosity level to hpc

Summary:
All commands now have `--verbosity` flag, so one can configure
cabal package with `--hpc-options="--verbosity=0"`.

Right now it is used only in `hpc markup` to supress unnecessary
output.

Reviewers: austin

Reviewed By: austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D660

GHC Trac Issues: #10091
parent 08102b3d
...@@ -21,6 +21,7 @@ sum_options ...@@ -21,6 +21,7 @@ sum_options
. includeOpt . includeOpt
. outputOpt . outputOpt
. unionModuleOpt . unionModuleOpt
. verbosityOpt
sum_plugin :: Plugin sum_plugin :: Plugin
sum_plugin = Plugin { name = "sum" sum_plugin = Plugin { name = "sum"
...@@ -40,6 +41,7 @@ combine_options ...@@ -40,6 +41,7 @@ combine_options
. combineFunOpt . combineFunOpt
. combineFunOptInfo . combineFunOptInfo
. unionModuleOpt . unionModuleOpt
. verbosityOpt
combine_plugin :: Plugin combine_plugin :: Plugin
combine_plugin = Plugin { name = "combine" combine_plugin = Plugin { name = "combine"
...@@ -59,6 +61,7 @@ map_options ...@@ -59,6 +61,7 @@ map_options
. mapFunOpt . mapFunOpt
. mapFunOptInfo . mapFunOptInfo
. unionModuleOpt . unionModuleOpt
. verbosityOpt
map_plugin :: Plugin map_plugin :: Plugin
map_plugin = Plugin { name = "map" map_plugin = Plugin { name = "map"
......
...@@ -20,6 +20,7 @@ draft_options ...@@ -20,6 +20,7 @@ draft_options
. hpcDirOpt . hpcDirOpt
. resetHpcDirsOpt . resetHpcDirsOpt
. outputOpt . outputOpt
. verbosityOpt
draft_plugin :: Plugin draft_plugin :: Plugin
draft_plugin = Plugin { name = "draft" draft_plugin = Plugin { name = "draft"
......
...@@ -27,6 +27,8 @@ data Flags = Flags ...@@ -27,6 +27,8 @@ data Flags = Flags
, combineFun :: CombineFun -- tick-wise combine , combineFun :: CombineFun -- tick-wise combine
, postFun :: PostFun -- , postFun :: PostFun --
, mergeModule :: MergeFun -- module-wise merge , mergeModule :: MergeFun -- module-wise merge
, verbosity :: Verbosity
} }
default_flags :: Flags default_flags :: Flags
...@@ -48,9 +50,21 @@ default_flags = Flags ...@@ -48,9 +50,21 @@ default_flags = Flags
, combineFun = ADD , combineFun = ADD
, postFun = ID , postFun = ID
, mergeModule = INTERSECTION , mergeModule = INTERSECTION
, verbosity = Normal
} }
data Verbosity = Silent | Normal | Verbose
deriving (Eq, Ord)
verbosityFromString :: String -> Verbosity
verbosityFromString "0" = Silent
verbosityFromString "1" = Normal
verbosityFromString "2" = Verbose
verbosityFromString v = error $ "unknown verbosity: " ++ v
-- We do this after reading flags, because the defaults -- We do this after reading flags, because the defaults
-- depends on if specific flags we used. -- depends on if specific flags we used.
...@@ -73,7 +87,7 @@ infoArg :: String -> FlagOptSeq ...@@ -73,7 +87,7 @@ infoArg :: String -> FlagOptSeq
infoArg info = (:) $ Option [] [] (NoArg $ id) info infoArg info = (:) $ Option [] [] (NoArg $ id) info
excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt, excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt,
destDirOpt, outputOpt, destDirOpt, outputOpt, verbosityOpt,
perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt, perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt, altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
mapFunOptInfo, unionModuleOpt :: FlagOptSeq mapFunOptInfo, unionModuleOpt :: FlagOptSeq
...@@ -100,6 +114,11 @@ destDirOpt = anArg "destdir" "path to write output to" "DIR" ...@@ -100,6 +114,11 @@ destDirOpt = anArg "destdir" "path to write output to" "DIR"
outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a } outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
verbosityOpt = anArg "verbosity" "verbosity level, 0-2" "[0-2]"
(\ a f -> f { verbosity = verbosityFromString a })
. infoArg "default 1"
-- markup -- markup
perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True } perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
......
...@@ -32,6 +32,7 @@ markup_options ...@@ -32,6 +32,7 @@ markup_options
. funTotalsOpt . funTotalsOpt
. altHighlightOpt . altHighlightOpt
. destDirOpt . destDirOpt
. verbosityOpt
markup_plugin :: Plugin markup_plugin :: Plugin
markup_plugin = Plugin { name = "markup" markup_plugin = Plugin { name = "markup"
...@@ -76,7 +77,8 @@ markup_main flags (prog:modNames) = do ...@@ -76,7 +77,8 @@ markup_main flags (prog:modNames) = do
let writeSummary filename cmp = do let writeSummary filename cmp = do
let mods' = sortBy cmp mods let mods' = sortBy cmp mods
putStrLn $ "Writing: " ++ (filename ++ ".html") unless (verbosity flags < Normal) $
putStrLn $ "Writing: " ++ (filename ++ ".html")
writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $ writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $
"<html>" ++ "<html>" ++
...@@ -223,7 +225,8 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do ...@@ -223,7 +225,8 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
let addLine n xs = "<span class=\"lineno\">" ++ padLeft 5 ' ' (show n) ++ " </span>" ++ xs let addLine n xs = "<span class=\"lineno\">" ++ padLeft 5 ' ' (show n) ++ " </span>" ++ xs
let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
let fileName = modName0 ++ ".hs.html" let fileName = modName0 ++ ".hs.html"
putStrLn $ "Writing: " ++ fileName unless (verbosity flags < Normal) $
putStrLn $ "Writing: " ++ fileName
writeFileUsing (dest_dir ++ "/" ++ fileName) $ writeFileUsing (dest_dir ++ "/" ++ fileName) $
unlines ["<html>", unlines ["<html>",
"<head>", "<head>",
......
...@@ -15,6 +15,7 @@ overlay_options ...@@ -15,6 +15,7 @@ overlay_options
. hpcDirOpt . hpcDirOpt
. resetHpcDirsOpt . resetHpcDirsOpt
. outputOpt . outputOpt
. verbosityOpt
overlay_plugin :: Plugin overlay_plugin :: Plugin
overlay_plugin = Plugin { name = "overlay" overlay_plugin = Plugin { name = "overlay"
......
...@@ -274,5 +274,6 @@ report_options ...@@ -274,5 +274,6 @@ report_options
. hpcDirOpt . hpcDirOpt
. resetHpcDirsOpt . resetHpcDirsOpt
. xmlOutputOpt . xmlOutputOpt
. verbosityOpt
...@@ -15,6 +15,7 @@ showtix_options ...@@ -15,6 +15,7 @@ showtix_options
. hpcDirOpt . hpcDirOpt
. resetHpcDirsOpt . resetHpcDirsOpt
. outputOpt . outputOpt
. verbosityOpt
showtix_plugin :: Plugin showtix_plugin :: Plugin
showtix_plugin = Plugin { name = "show" showtix_plugin = Plugin { name = "show"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment