aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Interface.hs106
1 files changed, 49 insertions, 57 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"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:37:40 +0000