Add verbosity flag and utils, remove "verbose" flag

3 files changed, 30 insertions, 5 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index d46ca565..99b93847 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -15,7 +15,7 @@ module Haddock.Backends.Hoogle (
 import Haddock.GHC
 import Haddock.GHC.Utils
 import Haddock.Types
-import Haddock.Utils
+import Haddock.Utils hiding (out)
 import GHC
 import SrcLoc
 import Outputable
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 09ce47fe..e1647b1f 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -72,7 +72,7 @@ data Flag
   | Flag_WikiModuleURL String
   | Flag_WikiEntityURL String
   | Flag_Help
-  | Flag_Verbose
+  | Flag_Verbosity String
   | Flag_Version
   | Flag_UseContents String
   | Flag_GenContents
@@ -133,8 +133,8 @@ options backwardsCompat =
 	"display this help and exit",
     Option ['V']  ["version"]  (NoArg Flag_Version)
 	"output version information and exit",
-    Option ['v']  ["verbose"]  (NoArg Flag_Verbose)
-        "increase verbosity",
+    Option ['v']  ["verbosity"]  (ReqArg Flag_Verbosity "VERBOSITY")
+        "set verbosity level",
     Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
 	"use a separately-generated HTML contents page",
     Option [] ["gen-contents"] (NoArg Flag_GenContents)
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 70421c23..3bab9edf 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -39,7 +39,11 @@ module Haddock.Utils (
 --  FormatVersion, mkFormatVersion  
   
   -- * MTL stuff
-  MonadIO(..)
+  MonadIO(..),
+  
+  -- * Logging
+  parseVerbosity,
+  out
  ) where
 
 import Haddock.Types
@@ -66,6 +70,8 @@ import System.Environment ( getProgName )
 import System.Exit ( exitWith, ExitCode(..) )
 import System.IO ( hPutStr, stderr )
 import System.IO.Unsafe	 ( unsafePerformIO )
+import Distribution.Verbosity
+import Distribution.ReadE
 
 #if __GLASGOW_HASKELL__ >= 609
 import MonadUtils ( MonadIO(..) )
@@ -75,6 +81,25 @@ class Monad m => MonadIO m where
 instance MonadIO IO where liftIO = id
 #endif
 
+
+-- -----------------------------------------------------------------------------
+-- Logging
+
+
+parseVerbosity :: String -> Either String Verbosity
+parseVerbosity str = runReadE flagToVerbosity str
+
+
+-- | Print a message to stdout, if it is not too verbose
+out :: MonadIO m
+    => Verbosity -- ^ program verbosity
+    -> Verbosity -- ^ message verbosity
+    -> String -> m ()
+out progVerbosity msgVerbosity msg
+  | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg
+  | otherwise = return ()
+
+
 -- -----------------------------------------------------------------------------
 -- Some Utilities