Add some basic "verbose" mode logging in H.Interface

2 files changed, 51 insertions, 61 deletions

diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index d9ac2e94..9ea144ac 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -31,6 +31,7 @@ import Data.Map (Map)
 import Data.List
 import Control.Monad
 import Control.Exception ( evaluate )
+import Distribution.Verbosity
 
 import GHC
 import Name
@@ -44,34 +45,27 @@ 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] -> [Flag] -> [InterfaceFile]
-                 -> Ghc ([Interface], LinkEnv)
-createInterfaces modules flags extIfaces = do
+createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv)
+createInterfaces modules externalLinks flags = do
   -- part 1, create interfaces
-  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
-                                   , iface <- ifInstalledIfaces ext ]
-  interfaces <- createInterfaces' modules flags instIfaceMap
+  interfaces <- createInterfaces' modules flags
 #else
-createInterfaces :: Session -> [String] -> [Flag]
-                 -> [InterfaceFile] -> IO ([Interface], LinkEnv)
-createInterfaces session modules flags extIfaces = do
+createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv)
+createInterfaces session modules externalLinks flags = do
   -- part 1, create interfaces
-  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
-                                   , iface <- ifInstalledIfaces ext ]
-  interfaces <- createInterfaces' session modules flags instIfaceMap
+  interfaces <- createInterfaces' session modules flags
 #endif
   -- part 2, build 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
+  let homeLinks = buildHomeLinks interfaces
+      links     = homeLinks `Map.union` externalLinks
       allNames  = Map.keys links
 
   -- part 3, attach instances
+  out verbosity verbose "Attaching instances..."
   let interfaces' = attachInstances interfaces allNames
 
   -- part 4, rename interfaces
+  out verbosity verbose "Renaming interfaces..."
   let warnings = Flag_NoWarnings `notElem` flags
   let (interfaces'', msgs) = 
          runWriter $ mapM (renameInterface links warnings) interfaces'
@@ -81,8 +75,8 @@ createInterfaces session modules flags extIfaces = do
 
 
 #if __GLASGOW_HASKELL__ >= 609
-createInterfaces' :: [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
-createInterfaces' modules flags instIfaceMap = do
+createInterfaces' :: [String] -> [Flag] -> Ghc [Interface]
+createInterfaces' modules flags = do
   targets <- mapM (\f -> guessTarget f Nothing) modules
   setTargets targets
   modgraph <- depanal [] False
@@ -108,10 +102,10 @@ createInterfaces' modules flags instIfaceMap = do
 
   let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing
   (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
-    x <- processModule modsum flags modMap instIfaceMap
+    interface <- processModule modsum flags modMap
 #else
-createInterfaces' :: Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
-createInterfaces' session modules flags instIfaceMap = do
+createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface]
+createInterfaces' session modules flags = do
   targets <- mapM (\f -> guessTarget f Nothing) modules
   setTargets session targets
   mbGraph <- depanal session [] False
@@ -120,7 +114,7 @@ createInterfaces' session modules flags instIfaceMap = do
     Nothing -> throwE "Failed to create dependency graph"
   let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
   (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
-    x <- processModule session modsum flags modMap instIfaceMap
+    interface <- processModule session modsum flags modMap
 #endif
     case x of
       Just interface ->
@@ -162,43 +156,41 @@ ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++
 -}
 
 #if __GLASGOW_HASKELL__ >= 609
-processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
-processModule modsum flags modMap instIfaceMap = do
-  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
-      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
-      liftIO $ mapM_ putStrLn msg
-      liftIO $ evaluate interface
-      return (Just interface)
-    else
-      return Nothing
+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
 #else
-processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)
-processModule session modsum flags modMap instIfaceMap = do
+processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface
+processModule session modsum flags modMap = do
   let filename = msHsFilePath modsum
   mbMod <- checkAndLoadModule session modsum False
-  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
+  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
 #endif
 
 -- | Build a mapping which for each original name, points to the "best"
diff --git a/src/Main.hs b/src/Main.hs
index e24954de..e12d5e04 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -176,8 +176,7 @@ main = handleTopExceptions $ do
 
 
         -- create the interfaces -- this is the core part of Haddock
-        (interfaces, homeLinks) <- createInterfaces fileArgs flags
-                                                    (map fst packages)
+        (interfaces, homeLinks) <- createInterfaces fileArgs extLinks flags
 
         liftIO $ do
           -- render the interfaces
@@ -193,8 +192,7 @@ main = handleTopExceptions $ do
       packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)
 
       -- create the interfaces -- this is the core part of Haddock
-      (interfaces, homeLinks) <- createInterfaces session fileArgs flags
-                                                  (map fst packages)
+      (interfaces, homeLinks) <- createInterfaces session fileArgs extLinks flags
 
       -- render the interfaces
       renderStep packages interfaces