Follow recent API additions with some refactorings

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

3 files changed, 120 insertions, 98 deletions

diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
index f277bf78..cfa1220d 100644
--- a/src/Documentation/Haddock.hs
+++ b/src/Documentation/Haddock.hs
@@ -17,7 +17,7 @@ module Documentation.Haddock (
   Interface(..),
   InstalledInterface(..),
   createInterfaces,
-  createInterfaces',
+  processModules,
 
   -- * Export items & declarations
   ExportItem(..),
@@ -63,3 +63,17 @@ import Haddock.Types
 import Haddock.Options
 import Haddock.Utils
 import Main
+
+
+-- | 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.
+createInterfaces
+  :: [Flag]         -- ^ A list of command-line flags
+  -> [String]       -- ^ File or module names
+  -> IO [Interface] -- ^ Resulting list of interfaces
+createInterfaces flags modules = do
+  (_, ifaces, _) <- readPackagesAndProcessModules flags modules
+  return ifaces
+
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index b25ed4ec..fbc2a7d3 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -27,7 +27,7 @@
 -- using this environment.
 -----------------------------------------------------------------------------
 module Haddock.Interface (
-  createInterfaces
+  processModules
 ) where
 
 
@@ -54,26 +54,27 @@ import GHC hiding (verbosity, flags)
 import HscTypes
 
 
--- | Create 'Interface' structures by typechecking the list of modules
--- using the GHC API and processing the resulting syntax trees.
-createInterfaces
-  :: Verbosity -- ^ Verbosity of logging to 'stdout'
-  -> [String] -- ^ A list of file or module names sorted by module topology
-  -> [Flag] -- ^ Command-line flags
-  -> [InterfaceFile] -- ^ Interface files of package dependencies
-  -> Ghc ([Interface], LinkEnv)
-  -- ^ Resulting list of interfaces and renaming environment
-createInterfaces verbosity modules flags extIfaces = do
+-- | Create 'Interface's and a link environment by typechecking the list of
+-- modules using the GHC API and processing the resulting syntax trees.
+processModules
+  :: Verbosity                  -- ^ Verbosity of logging to 'stdout'
+  -> [String]                   -- ^ A list of file or module names sorted by
+                                -- module topology
+  -> [Flag]                     -- ^ Command-line flags
+  -> [InterfaceFile]            -- ^ Interface files of package dependencies
+  -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
+                                -- environment
+processModules verbosity modules flags extIfaces = do
 
   out verbosity verbose "Creating interfaces..."
   let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
                                    , iface <- ifInstalledIfaces ext ]
-  interfaces <- createInterfaces' verbosity modules flags instIfaceMap
+  interfaces <- createIfaces0 verbosity modules flags instIfaceMap
 
   out verbosity verbose "Attaching instances..."
   interfaces' <- attachInstances interfaces instIfaceMap
 
-  out verbosity verbose "Building link environment..."
+  out verbosity verbose "Building cross-linking environment..."
   -- Combine the link envs of the external packages into one
   let extLinks  = Map.unions (map ifLinkEnv extIfaces)
       homeLinks = buildHomeLinks interfaces -- Build the environment for the home
@@ -89,51 +90,58 @@ createInterfaces verbosity modules flags extIfaces = do
   return (interfaces'', homeLinks)
 
 
-createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
-createInterfaces' verbosity modules flags instIfaceMap = do
-  let useTempDir = Flag_NoTmpCompDir `notElem` flags
+--------------------------------------------------------------------------------
+-- * Module typechecking and Interface creation
+--------------------------------------------------------------------------------
 
-  -- Output dir needs to be set before calling depanal since it uses it to
+
+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createIfaces0 verbosity modules flags instIfaceMap =
+  -- Output dir needs to be set before calling depanal since depanal uses it to
   -- compute output file names that are stored in the DynFlags of the
   -- resulting ModSummaries.
-  tmp <- liftIO getTemporaryDirectory
-  x   <- liftIO getProcessID
-  let tempDir = tmp </> ".haddock-" ++ show x
-  when useTempDir $ modifySessionDynFlags (setOutputDir tempDir)
-
-  targets <- mapM (\f -> guessTarget f Nothing) modules
-  setTargets targets
-  -- Dependency analysis.
-  modgraph <- depanal [] False
-
-  -- If template haskell is used by the package, we can't use HscNothing as
-  -- target since we might need to run code generated from one or more of the
-  -- modules during typechecking.
-  if needsTemplateHaskell modgraph
-    then
-      -- Create a temporary directory in wich to write compilation output,
-      -- unless the user has asked us not to.
-      (if useTempDir then withTempDir tempDir else id) $ do
-        -- Turn on compilation.
-        let enableComp d = d { hscTarget = defaultObjectTarget }
-        modifySessionDynFlags enableComp
-        -- We need to update the DynFlags of the ModSummaries as well.
-        let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
-        let modgraph' = map upd modgraph
-
-        processModules verbosity flags instIfaceMap modgraph'
-    else
-      processModules verbosity flags instIfaceMap modgraph
+  (if useTempDir then withTempOutputDir else id) $ do
+    modGraph <- depAnalysis
+    if needsTemplateHaskell modGraph
+      then do
+        modGraph' <- enableCompilation modGraph
+        createIfaces verbosity flags instIfaceMap modGraph'
+      else
+        createIfaces verbosity flags instIfaceMap modGraph
 
+  where
+    useTempDir :: Bool
+    useTempDir = Flag_NoTmpCompDir `notElem` flags
 
-withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
-withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
-                            (liftIO $ removeDirectoryRecursive dir)
+
+    withTempOutputDir :: Ghc a -> Ghc a
+    withTempOutputDir action = do
+      tmp <- liftIO getTemporaryDirectory
+      x   <- liftIO getProcessID
+      let dir = tmp </> ".haddock-" ++ show x
+      modifySessionDynFlags (setOutputDir dir)
+      withTempDir dir action
+
+
+    depAnalysis :: Ghc ModuleGraph
+    depAnalysis = do
+      targets <- mapM (\f -> guessTarget f Nothing) modules
+      setTargets targets
+      depanal [] False
+
+
+    enableCompilation :: ModuleGraph -> Ghc ModuleGraph
+    enableCompilation modGraph = do
+      let enableComp d = d { hscTarget = defaultObjectTarget }
+      modifySessionDynFlags enableComp
+      -- We need to update the DynFlags of the ModSummaries as well.
+      let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
+      let modGraph' = map upd modGraph
+      return modGraph'
 
 
-processModules :: Verbosity -> [Flag] -> InstIfaceMap -> [ModSummary]
-               -> Ghc [Interface]
-processModules verbosity flags instIfaceMap mods = do
+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
+createIfaces verbosity flags instIfaceMap mods = do
   let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
   (ifaces, _) <- foldM f ([], Map.empty) sortedMods
   return (reverse ifaces)
@@ -200,6 +208,11 @@ mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
     (_, renamed, _, modInfo) = checkedMod
 
 
+--------------------------------------------------------------------------------
+-- * Building of cross-linking environment  
+--------------------------------------------------------------------------------
+
+
 -- | Build a mapping which for each original name, points to the "best"
 -- place to link to in the documentation.  For the definition of
 -- "best", we use "the module nearest the bottom of the dependency
@@ -221,3 +234,14 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
         mdl            = ifaceMod iface
         keep_old env n = Map.insertWith (\_ old -> old) n mdl env
         keep_new env n = Map.insert n mdl env
+
+
+--------------------------------------------------------------------------------
+-- * Utils
+--------------------------------------------------------------------------------
+
+
+withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
+withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
+                            (liftIO $ removeDirectoryRecursive dir)
+
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