aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface.hs')
-rw-r--r--src/Haddock/Interface.hs109
1 files changed, 63 insertions, 46 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"
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 12:30:32 +0000