diff options
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 2 | ||||
| -rw-r--r-- | src/Haddock/Options.hs | 6 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 27 | ||||
| -rw-r--r-- | src/Main.hs | 12 |
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 |