aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Interface.hs2
-rw-r--r--src/Haddock/Options.hs29
-rw-r--r--src/Main.hs30
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