Fix conflicts

2 files changed, 67 insertions, 48 deletions

diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 9ea144ac..3f959721 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -45,19 +45,31 @@ import HscTypes
 -- | Turn a topologically sorted list of module names/filenames into interfaces. Also
 -- return the home link environment created in the process.
 #if __GLASGOW_HASKELL__ >= 609
-createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv)
-createInterfaces modules externalLinks flags = do
+createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile]
+                 -> Ghc ([Interface], LinkEnv)
+createInterfaces verbosity modules flags extIfaces = do
   -- part 1, create interfaces
-  interfaces <- createInterfaces' modules flags
+  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+                                   , iface <- ifInstalledIfaces ext ]
+  out verbosity verbose "Creating interfaces..."
+  interfaces <- createInterfaces' verbosity modules flags instIfaceMap
 #else
-createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv)
-createInterfaces session modules externalLinks flags = do
+createInterfaces :: Verbosity -> Session -> [String] -> [Flag]
+                 -> [InterfaceFile] -> IO ([Interface], LinkEnv)
+createInterfaces verbosity session modules flags extIfaces = do
   -- part 1, create interfaces
-  interfaces <- createInterfaces' session modules flags
+  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+                                   , iface <- ifInstalledIfaces ext ]
+  out verbosity verbose "Creating interfaces..."
+  interfaces <- createInterfaces' verbosity session modules flags instIfaceMap
 #endif
   -- part 2, build link environment
-  let homeLinks = buildHomeLinks interfaces
-      links     = homeLinks `Map.union` externalLinks
+  out verbosity verbose "Building link 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
+                                            -- package
+      links     = homeLinks `Map.union` extLinks
       allNames  = Map.keys links
 
   -- part 3, attach instances
@@ -75,8 +87,8 @@ createInterfaces session modules externalLinks flags = do
 
 
 #if __GLASGOW_HASKELL__ >= 609
-createInterfaces' :: [String] -> [Flag] -> Ghc [Interface]
-createInterfaces' modules flags = do
+createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createInterfaces' verbosity modules flags instIfaceMap = do
   targets <- mapM (\f -> guessTarget f Nothing) modules
   setTargets targets
   modgraph <- depanal [] False
@@ -102,10 +114,10 @@ createInterfaces' modules flags = do
 
   let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing
   (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
-    interface <- processModule modsum flags modMap
+    x <- processModule verbosity modsum flags modMap instIfaceMap
 #else
-createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface]
-createInterfaces' session modules flags = do
+createInterfaces' :: Verbosity -> Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
+createInterfaces' verbosity session modules flags instIfaceMap = do
   targets <- mapM (\f -> guessTarget f Nothing) modules
   setTargets session targets
   mbGraph <- depanal session [] False
@@ -114,7 +126,7 @@ createInterfaces' session modules flags = do
     Nothing -> throwE "Failed to create dependency graph"
   let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
   (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
-    interface <- processModule session modsum flags modMap
+    x <- processModule verbosity session modsum flags modMap instIfaceMap
 #endif
     case x of
       Just interface ->
@@ -156,41 +168,46 @@ ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++
 -}
 
 #if __GLASGOW_HASKELL__ >= 609
-processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface
-processModule modsum flags modMap = 
-
-  let handleSrcErrors action = flip handleSourceError action $ \err -> do 
-        printExceptionAndWarnings err
-        throwE ("Failed to check module: " ++ moduleString (ms_mod modsum))
-
-  in handleSrcErrors $ do
-       let filename = msHsFilePath modsum
-       let dynflags = ms_hspp_opts modsum
-       tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum
-       let Just renamed_src = renamedSource tc_mod
-       let ghcMod = mkGhcModule (ms_mod modsum,
-                             filename,
-                             (parsedSource tc_mod,
-                              renamed_src,
-                              typecheckedSource tc_mod,
-                              moduleInfo tc_mod))
-                             dynflags
-       let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
-       liftIO $ mapM_ putStrLn msg
-       liftIO $ evaluate interface
-       return interface
+processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule verbosity modsum flags modMap instIfaceMap = do
+  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
+  tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum
+  if not $ isBootSummary modsum
+    then do
+      let filename = msHsFilePath modsum
+      let dynflags = ms_hspp_opts modsum
+      let Just renamed_src = renamedSource tc_mod
+      let ghcMod = mkGhcModule (ms_mod modsum,
+                            filename,
+                            (parsedSource tc_mod,
+                             renamed_src,
+                             typecheckedSource tc_mod,
+                             moduleInfo tc_mod))
+                            dynflags
+      out verbosity verbose "Creating interface..."
+      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
+      liftIO $ mapM_ putStrLn msg
+      liftIO $ evaluate interface
+      return (Just interface)
+    else
+      return Nothing
 #else
-processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface
-processModule session modsum flags modMap = do
+processModule :: Verbosity -> Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)
+processModule verbosity session modsum flags modMap instIfaceMap = do
+  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
   let filename = msHsFilePath modsum
   mbMod <- checkAndLoadModule session modsum False
-  ghcMod <- case mbMod of
-    Just (CheckedModule a (Just b) (Just c) (Just d) _)
-      -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
-    _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
-  let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
-  mapM_ putStrLn msg
-  return interface
+  if not $ isBootSummary modsum
+    then do
+      ghcMod <- case mbMod of
+        Just (CheckedModule a (Just b) (Just c) (Just d) _)
+          -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
+        _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
+      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
+      mapM_ putStrLn msg
+      return (Just interface)
+    else
+      return Nothing
 #endif
 
 -- | Build a mapping which for each original name, points to the "best"
diff --git a/src/Main.hs b/src/Main.hs
index e12d5e04..e1f276cf 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -176,7 +176,8 @@ main = handleTopExceptions $ do
 
 
         -- create the interfaces -- this is the core part of Haddock
-        (interfaces, homeLinks) <- createInterfaces fileArgs extLinks flags
+        (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags
+                                                    (map fst packages)
 
         liftIO $ do
           -- render the interfaces
@@ -192,7 +193,8 @@ main = handleTopExceptions $ do
       packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)
 
       -- create the interfaces -- this is the core part of Haddock
-      (interfaces, homeLinks) <- createInterfaces session fileArgs extLinks flags
+      (interfaces, homeLinks) <- createInterfaces verbosity session fileArgs flags
+                                                  (map fst packages)
 
       -- render the interfaces
       renderStep packages interfaces