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

7 files changed, 32 insertions, 3 deletions

diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs
index b57112f45e..db6ae9c948 100644
--- a/utils/hpc/HpcCombine.hs
+++ b/utils/hpc/HpcCombine.hs
@@ -21,6 +21,7 @@ sum_options
         . includeOpt
         . outputOpt
         . unionModuleOpt
+        . verbosityOpt
 
 sum_plugin :: Plugin
 sum_plugin = Plugin { name = "sum"
@@ -40,6 +41,7 @@ combine_options
         . combineFunOpt
         . combineFunOptInfo
         . unionModuleOpt
+        . verbosityOpt
 
 combine_plugin :: Plugin
 combine_plugin = Plugin { name = "combine"
@@ -59,6 +61,7 @@ map_options
         . mapFunOpt
         . mapFunOptInfo
         . unionModuleOpt
+        . verbosityOpt
 
 map_plugin :: Plugin
 map_plugin = Plugin { name = "map"
diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs
index b804d568e4..975dbf4f65 100644
--- a/utils/hpc/HpcDraft.hs
+++ b/utils/hpc/HpcDraft.hs
@@ -20,6 +20,7 @@ draft_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . outputOpt
+        . verbosityOpt
 
 draft_plugin :: Plugin
 draft_plugin = Plugin { name = "draft"
diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs
index 3bb31639b1..017030986a 100644
--- a/utils/hpc/HpcFlags.hs
+++ b/utils/hpc/HpcFlags.hs
@@ -27,6 +27,8 @@ data Flags = Flags
   , combineFun          :: CombineFun   -- tick-wise combine
   , postFun             :: PostFun      --
   , mergeModule         :: MergeFun     -- module-wise merge
+
+  , verbosity           :: Verbosity
   }
 
 default_flags :: Flags
@@ -48,9 +50,21 @@ default_flags = Flags
   , combineFun          = ADD
   , postFun             = ID
   , 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
 -- depends on if specific flags we used.
 
@@ -73,7 +87,7 @@ infoArg :: String -> FlagOptSeq
 infoArg info = (:) $ Option [] [] (NoArg $ id) info
 
 excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt,
-    destDirOpt, outputOpt,
+    destDirOpt, outputOpt, verbosityOpt,
     perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
     altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
     mapFunOptInfo, unionModuleOpt :: FlagOptSeq
@@ -100,6 +114,11 @@ destDirOpt      = anArg "destdir"   "path to write output to" "DIR"
 
 
 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
 
 perModuleOpt  = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs
index c294b6a94e..1373bfbee5 100644
--- a/utils/hpc/HpcMarkup.hs
+++ b/utils/hpc/HpcMarkup.hs
@@ -32,6 +32,7 @@ markup_options
         . funTotalsOpt
         . altHighlightOpt
         . destDirOpt
+        . verbosityOpt
 
 markup_plugin :: Plugin
 markup_plugin = Plugin { name = "markup"
@@ -76,7 +77,8 @@ markup_main flags (prog:modNames) = do
   let writeSummary filename cmp = do
         let mods' = sortBy cmp mods
 
-        putStrLn $ "Writing: " ++ (filename ++ ".html")
+        unless (verbosity flags < Normal) $
+            putStrLn $ "Writing: " ++ (filename ++ ".html")
 
         writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $
             "<html>" ++
@@ -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 addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
   let fileName = modName0 ++ ".hs.html"
-  putStrLn $ "Writing: " ++ fileName
+  unless (verbosity flags < Normal) $
+            putStrLn $ "Writing: " ++ fileName
   writeFileUsing (dest_dir ++ "/" ++ fileName) $
             unlines ["<html>",
                      "<head>",
diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs
index 531018cd0c..c4f8e96bf4 100644
--- a/utils/hpc/HpcOverlay.hs
+++ b/utils/hpc/HpcOverlay.hs
@@ -15,6 +15,7 @@ overlay_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . outputOpt
+        . verbosityOpt
 
 overlay_plugin :: Plugin
 overlay_plugin = Plugin { name = "overlay"
diff --git a/utils/hpc/HpcReport.hs b/utils/hpc/HpcReport.hs
index a97d6b0981..4c975be425 100644
--- a/utils/hpc/HpcReport.hs
+++ b/utils/hpc/HpcReport.hs
@@ -274,5 +274,6 @@ report_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . xmlOutputOpt
+        . verbosityOpt
 
 
diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs
index 13a28754aa..f0c628e422 100644
--- a/utils/hpc/HpcShowTix.hs
+++ b/utils/hpc/HpcShowTix.hs
@@ -15,6 +15,7 @@ showtix_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . outputOpt
+        . verbosityOpt
 
 showtix_plugin :: Plugin
 showtix_plugin = Plugin { name = "show"