aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Interface.hs45
-rw-r--r--src/Haddock/Interface/Create.hs33
-rw-r--r--src/Haddock/Types.hs23
-rw-r--r--src/Main.hs2
4 files changed, 22 insertions, 81 deletions
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index fbc2a7d3..0c171cbc 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -43,7 +43,6 @@ import Haddock.Utils
import Control.Monad
import Data.List
import qualified Data.Map as Map
-import Data.Maybe
import Distribution.Verbosity
import System.Directory
import System.FilePath
@@ -156,21 +155,11 @@ createIfaces verbosity flags instIfaceMap mods = do
processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> 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
+ tm <- 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..."
- (interface, msg) <- runWriterGhc $ createInterface ghcMod flags modMap instIfaceMap
+ (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
interface' <- liftIO $ evaluate interface
return (Just interface')
@@ -178,36 +167,6 @@ processModule verbosity modsum flags modMap instIfaceMap = do
return Nothing
-type CheckedMod = (Module, FilePath, FullyCheckedMod)
-
-
-type FullyCheckedMod = (ParsedSource,
- RenamedSource,
- TypecheckedSource,
- ModuleInfo)
-
-
--- | Dig out what we want from the typechecker output
-mkGhcModule :: CheckedMod -> DynFlags -> GhcModule
-mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
- ghcModule = mdl,
- ghcFilename = file,
- ghcMbDocOpts = mbOpts,
- ghcMbDocHdr = mbDocHdr,
- ghcGroup = group_,
- ghcMbExports = mbExports,
- ghcExportedNames = modInfoExports modInfo,
- ghcDefinedNames = map getName $ modInfoTyThings modInfo,
- ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
- ghcInstances = modInfoInstances modInfo,
- ghcDynFlags = dynflags
-}
- where
- mbOpts = haddockOptions dynflags
- (group_, _, mbExports, mbDocHdr) = renamed
- (_, renamed, _, modInfo) = checkedMod
-
-
--------------------------------------------------------------------------------
-- * Building of cross-linking environment
--------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index c33e36cf..b6215a34 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -29,6 +29,7 @@ import Control.Monad
import qualified Data.Traversable as Traversable
import GHC hiding (flags)
+import HscTypes
import Name
import Bag
import RdrName (GlobalRdrEnv)
@@ -37,41 +38,43 @@ import RdrName (GlobalRdrEnv)
-- | Process the data in a GhcModule to produce an interface.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the interface map.
-createInterface :: GhcModule -> [Flag] -> IfaceMap -> InstIfaceMap
+createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap
-> ErrMsgGhc Interface
-createInterface ghcMod flags modMap instIfaceMap = do
+createInterface tm flags modMap instIfaceMap = do
- let mdl = ghcModule ghcMod
- dflags = ghcDynFlags ghcMod
+ let ms = pm_mod_summary . tm_parsed_module $ tm
+ mi = moduleInfo tm
+ mdl = ms_mod ms
+ dflags = ms_hspp_opts ms
+ instances = modInfoInstances mi
+ exportedNames = modInfoExports mi
+ -- XXX: confirm always a Just.
+ Just (group_, _, optExports, optDocHeader) = renamedSource tm
-- The pattern-match should not fail, because createInterface is only
-- done on loaded modules.
Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)
- opts0 <- liftErrMsg $ mkDocOpts (ghcMbDocOpts ghcMod) flags mdl
+ opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
let opts
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
+ (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre optDocHeader
+ decls0 <- liftErrMsg $ declInfos dflags gre (topDecls group_)
- (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags
- gre (ghcMbDocHdr ghcMod)
- decls0 <- liftErrMsg $ declInfos dflags gre (topDecls (ghcGroup ghcMod))
-
- let instances = ghcInstances ghcMod
- localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
+ let localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ]
instanceDocMap = mkInstanceDocMap localInsts declDocs
decls = filterOutInstances decls0
declMap = mkDeclMap decls
- exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
+ exports = fmap (reverse . map unLoc) optExports
ignoreExps = Flag_IgnoreAllExports `elem` flags
- exportedNames = ghcExportedNames ghcMod
liftErrMsg $ warnAboutFilteredDecls mdl decls0
- exportItems <- mkExportItems modMap mdl gre (ghcExportedNames ghcMod) decls declMap
+ exportItems <- mkExportItems modMap mdl gre exportedNames decls declMap
opts exports ignoreExps instances instIfaceMap dflags
let visibleNames = mkVisibleNames exportItems opts
@@ -85,7 +88,7 @@ createInterface ghcMod flags modMap instIfaceMap = do
return Interface {
ifaceMod = mdl,
- ifaceOrigFilename = ghcFilename ghcMod,
+ ifaceOrigFilename = msHsFilePath ms,
ifaceInfo = info,
ifaceDoc = mbDoc,
ifaceRnDoc = Nothing,
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index d862b56d..62a603ee 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -351,29 +351,6 @@ data DocOption
-----------------------------------------------------------------------------
--- * Misc.
------------------------------------------------------------------------------
-
-
--- TODO: remove?
--- | This structure holds the module information we get from GHC's
--- type checking phase
-data GhcModule = GhcModule {
- ghcModule :: Module,
- ghcFilename :: FilePath,
- ghcMbDocOpts :: Maybe String,
- ghcMbDocHdr :: GhcDocHdr,
- ghcGroup :: HsGroup Name,
- ghcMbExports :: Maybe [LIE Name],
- ghcExportedNames :: [Name],
- ghcDefinedNames :: [Name],
- ghcNamesInScope :: [Name],
- ghcInstances :: [Instance],
- ghcDynFlags :: DynFlags
-}
-
-
------------------------------------------------------------------------------
-- * Error handling
-----------------------------------------------------------------------------
diff --git a/src/Main.hs b/src/Main.hs
index 1192b1fb..22a649d2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -146,6 +146,8 @@ main = handleTopExceptions $ do
renderStep flags packages []
+readPackagesAndProcessModules :: [Flag] -> [String] -> IO ([(InterfaceFile, FilePath)],
+ [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
libDir <- getGhcLibDir flags
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 03:04:38 +0000