Follow recent API additions with some refactorings

Simon Hegel's patch prompted me to do some refactorings in Main,
Haddock.Documentation and Haddock.Interface. 

1 files changed, 30 insertions, 46 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 5c0d0174..1192b1fb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,7 +15,7 @@
 --
 -- Program entry point and top-level code.
 -----------------------------------------------------------------------------
-module Main (main, createInterfaces') where
+module Main (main, readPackagesAndProcessModules) where
 
 
 import Haddock.Backends.Xhtml
@@ -115,59 +115,22 @@ handleGhcExceptions =
 -------------------------------------------------------------------------------
 
 
--- | Create 'Interface' structures from a given list of Haddock command-line
--- flags and file or module names (as accepted by 'haddock' executable).  Flags
--- that control documentation generation or show help or version information
--- are ignored.
---
--- This is a more high-level alternative to 'createInterfaces'.
-createInterfaces'
-  :: [String]       -- ^ A list of command-line flags and file or module names
-  -> IO [Interface] -- ^ Resulting list of interfaces
-createInterfaces' args = do
-  (flags, fileArgs) <- parseHaddockOpts args
-  (_, ifaces) <- readPackagesAndCreateInterfaces flags fileArgs
-  return ifaces
-
-
-readPackagesAndCreateInterfaces :: [Flag] -> [String] -> IO ([(InterfaceFile, FilePath)], [Interface])
-readPackagesAndCreateInterfaces flags fileArgs = do
-  libDir <- getGhcLibDir flags
-
-  -- Catches all GHC source errors, then prints and re-throws them.
-  let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
-        printExceptionAndWarnings err
-        liftIO exitFailure
-
-  -- Initialize GHC.
-  withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
-
-    -- Get packages supplied with --read-interface.
-    packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
-
-    -- Create the interfaces -- this is the core part of Haddock.
-    (ifaces, homeLinks) <- createInterfaces (verbosity flags) fileArgs flags
-                                            (map fst packages)
-
-    -- Dump an "interface file" (.haddock file), if requested.
-    liftIO $ case optDumpInterfaceFile flags of
-      Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
-      Nothing -> return ()
-
-    return (packages, ifaces)
-
-
 main :: IO ()
 main = handleTopExceptions $ do
 
   -- Parse command-line flags and handle some of them initially.
   args <- getArgs
-  (flags, fileArgs) <- parseHaddockOpts args
+  (flags, files) <- parseHaddockOpts args
   shortcutFlags flags
 
-  if not (null fileArgs)
+  if not (null files)
     then do
-      (packages, ifaces) <- readPackagesAndCreateInterfaces flags fileArgs
+      (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+
+      -- Dump an "interface file" (.haddock file), if requested.
+      case optDumpInterfaceFile flags of
+        Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
+        Nothing -> return ()
 
       -- Render the interfaces.
       renderStep flags packages ifaces
@@ -183,6 +146,27 @@ main = handleTopExceptions $ do
       renderStep flags packages []
 
 
+readPackagesAndProcessModules flags files = do
+  libDir <- getGhcLibDir flags
+
+  -- Catches all GHC source errors, then prints and re-throws them.
+  let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
+        printExceptionAndWarnings err
+        liftIO exitFailure
+
+  -- Initialize GHC.
+  withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
+
+    -- Get packages supplied with --read-interface.
+    packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
+
+    -- Create the interfaces -- this is the core part of Haddock.
+    let ifaceFiles = map fst packages
+    (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
+
+    return (packages, ifaces, homeLinks)
+
+
 renderStep :: [Flag] -> [(InterfaceFile, FilePath)] -> [Interface] -> IO ()
 renderStep flags packages interfaces = do
   updateHTMLXRefs packages