Add configurable verbosity level to hpc
authorYuras Shumovich <shumovichy@gmail.com>
Tue, 17 Feb 2015 14:39:54 +0000 (08:39 -0600)
committerAustin Seipp <austin@well-typed.com>
Tue, 17 Feb 2015 15:06:11 +0000 (09:06 -0600)
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

utils/hpc/HpcCombine.hs
utils/hpc/HpcDraft.hs
utils/hpc/HpcFlags.hs
utils/hpc/HpcMarkup.hs
utils/hpc/HpcOverlay.hs
utils/hpc/HpcReport.hs
utils/hpc/HpcShowTix.hs

index b57112f..db6ae9c 100644 (file)
@@ -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"
index b804d56..975dbf4 100644 (file)
@@ -20,6 +20,7 @@ draft_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . outputOpt
+        . verbosityOpt
 
 draft_plugin :: Plugin
 draft_plugin = Plugin { name = "draft"
index 3bb3163..0170309 100644 (file)
@@ -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 }
index c294b6a..1373bfb 100644 (file)
@@ -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>",
index 531018c..c4f8e96 100644 (file)
@@ -15,6 +15,7 @@ overlay_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . outputOpt
+        . verbosityOpt
 
 overlay_plugin :: Plugin
 overlay_plugin = Plugin { name = "overlay"
index a97d6b0..4c975be 100644 (file)
@@ -274,5 +274,6 @@ report_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . xmlOutputOpt
+        . verbosityOpt
 
 
index 13a2875..f0c628e 100644 (file)
@@ -15,6 +15,7 @@ showtix_options
         . hpcDirOpt
         . resetHpcDirsOpt
         . outputOpt
+        . verbosityOpt
 
 showtix_plugin :: Plugin
 showtix_plugin = Plugin { name = "show"