diff options
| -rw-r--r-- | src/Haddock/Interface.hs | 2 | ||||
| -rw-r--r-- | src/Haddock/Options.hs | 29 | ||||
| -rw-r--r-- | src/Main.hs | 30 |
3 files changed, 32 insertions, 29 deletions
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 22d55713..3397eecb 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -36,7 +36,7 @@ import Haddock.InterfaceFile import Haddock.Interface.Create import Haddock.Interface.AttachInstances import Haddock.Interface.Rename -import Haddock.Options +import Haddock.Options hiding (verbosity) import Haddock.Types import Haddock.Utils diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 7fdb7a35..de8191c7 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -23,12 +23,15 @@ module Haddock.Options ( optCssFile, optSourceUrls, optWikiUrls, + optDumpInterfaceFile, + verbosity, ghcFlags, ifacePairs ) where import Data.Maybe +import Distribution.Verbosity import Haddock.Utils import Haddock.Types import System.Console.GetOpt @@ -209,19 +212,31 @@ optWikiUrls flags = ,listToMaybe [str | Flag_WikiEntityURL str <- flags]) +optDumpInterfaceFile :: [Flag] -> Maybe FilePath +optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] + + +verbosity :: [Flag] -> Verbosity +verbosity flags = + case [ str | Flag_Verbosity str <- flags ] of + [] -> normal + x:_ -> case parseVerbosity x of + Left e -> throwE e + Right v -> v + + ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] ifacePairs :: [Flag] -> [(FilePath, FilePath)] ifacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] - - -parseIfaceOption :: String -> (FilePath, FilePath) -parseIfaceOption s = - case break (==',') s of - (fpath,',':file) -> (fpath, file) - (file, _) -> ("", file) + where + parseIfaceOption :: String -> (FilePath, FilePath) + parseIfaceOption str = + case break (==',') str of + (fpath, ',':file) -> (fpath, file) + (file, _) -> ("", file) -- | Like 'listToMaybe' but returns the last element instead of the first. diff --git a/src/Main.hs b/src/Main.hs index 082f69aa..af2be963 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -39,7 +39,6 @@ import qualified Data.Map as Map import System.IO import System.Exit import System.Environment -import Distribution.Verbosity #if defined(mingw32_HOST_OS) import Foreign @@ -120,7 +119,6 @@ main = handleTopExceptions $ do args <- getArgs (flags, fileArgs) <- parseHaddockOpts args handleEasyFlags flags - verbosity <- getVerbosity flags let renderStep packages interfaces = do updateHTMLXRefs packages @@ -145,14 +143,16 @@ main = handleTopExceptions $ do packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags) -- Create the interfaces -- this is the core part of Haddock. - (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags - (map fst packages) + (ifaces, homeLinks) <- createInterfaces (verbosity flags) fileArgs flags + (map fst packages) liftIO $ do -- Render the interfaces. - renderStep packages interfaces + renderStep packages ifaces - -- Last but not least, dump the interface file. - dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags + -- Dump an "interface file" (.haddock file), if requested. + case optDumpInterfaceFile flags of + Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks + Nothing -> return () else do -- Get packages supplied with --read-interface. @@ -250,11 +250,8 @@ readInterfaceFiles name_cache_accessor pairs = do Right f -> return $ Just (f, html) -dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO () -dumpInterfaceFile ifaces homeLinks flags = - case [str | Flag_DumpInterface str <- flags] of - [] -> return () - fs -> let filename = last fs in writeInterfaceFile filename ifaceFile +dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO () +dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile where ifaceFile = InterfaceFile { ifInstalledIfaces = ifaces, @@ -328,15 +325,6 @@ getGhcLibDir flags = xs -> return $ last xs -getVerbosity :: Monad m => [Flag] -> m Verbosity -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 :: [Flag] -> IO () handleEasyFlags flags = do usage <- getUsage |