From 618c9049612b1a8e4a7d3955e54c10446af94778 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 7 Dec 2008 20:01:05 +0000 Subject: Add some basic "verbose" mode logging in H.Interface --- src/Haddock/Interface.hs | 106 ++++++++++++++++++++++------------------------- 1 file changed, 49 insertions(+), 57 deletions(-) (limited to 'src/Haddock') 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" -- cgit v1.2.3