From 25efba7ea3721264c56ca0f8a57dd166080c7eed Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Fri, 14 May 2010 20:24:32 +0000
Subject: Move some more flag functions to Haddock.Options

---
 src/Haddock/Interface.hs |  2 +-
 src/Haddock/Options.hs   | 29 ++++++++++++++++++++++-------
 src/Main.hs              | 30 +++++++++---------------------
 3 files changed, 32 insertions(+), 29 deletions(-)

(limited to 'src')

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
-- 
cgit v1.2.3