Add verbosity flag and utils, remove "verbose" flag

4 files changed, 40 insertions, 7 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
 
diff --git a/src/Main.hs b/src/Main.hs
index 05b71223..e24954de 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -40,6 +40,7 @@ import System.IO
 import System.Exit
 import System.Environment
 import System.FilePath
+import Distribution.Verbosity
 
 #if defined(mingw32_HOST_OS)
 import Foreign
@@ -137,6 +138,7 @@ main = handleTopExceptions $ do
   args <- getArgs
   (flags, fileArgs) <- parseHaddockOpts args
   handleEasyFlags flags fileArgs
+  verbosity <- getVerbosity flags
 
   let renderStep packages interfaces = do 
         updateHTMLXRefs packages
@@ -229,8 +231,6 @@ render flags ifaces installedIfaces = do
                       ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
                       ,listToMaybe [str | Flag_WikiEntityURL str <- flags])
 
-    verbose = Flag_Verbose `elem` flags
-
   libdir <- case [str | Flag_Lib str <- flags] of
 		[] ->
 #ifdef IN_GHC_TREE
@@ -356,6 +356,14 @@ getGhcLibDir flags =
     xs -> Just $ last xs
 
 
+getVerbosity flags =
+  case [ str | Flag_Verbosity str <- flags ] of
+    [] -> return normal
+    x:_ -> case parseVerbosity x of
+      Left e -> throwE e
+      Right v -> return v
+
+
 handleEasyFlags flags fileArgs = do
   usage <- getUsage