[commit: ghc] ghc-7.10: Add configurable verbosity level to hpc (00693e1)

git at git.haskell.org git at git.haskell.org
Mon Feb 23 11:35:40 UTC 2015


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/00693e1ca9bd7c3225e1cbc377e57fb80a28d835/ghc

>---------------------------------------------------------------

commit 00693e1ca9bd7c3225e1cbc377e57fb80a28d835
Author: Yuras Shumovich <shumovichy at gmail.com>
Date:   Tue Feb 17 08:39:54 2015 -0600

    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
    
    (cherry picked from commit 1b82619bc2ff36341d916c56b0cd67a378a9c222)


>---------------------------------------------------------------

00693e1ca9bd7c3225e1cbc377e57fb80a28d835
 utils/hpc/HpcCombine.hs |  3 +++
 utils/hpc/HpcDraft.hs   |  1 +
 utils/hpc/HpcFlags.hs   | 21 ++++++++++++++++++++-
 utils/hpc/HpcMarkup.hs  |  7 +++++--
 utils/hpc/HpcOverlay.hs |  1 +
 utils/hpc/HpcReport.hs  |  1 +
 utils/hpc/HpcShowTix.hs |  1 +
 7 files changed, 32 insertions(+), 3 deletions(-)

diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs
index b57112f..db6ae9c 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 b804d56..975dbf4 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 3bb3163..0170309 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 c294b6a..1373bfb 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 531018c..c4f8e96 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 a97d6b0..4c975be 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 13a2875..f0c628e 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"



More information about the ghc-commits mailing list