From d830dca2ed25bb71b7c745feef715dab7de2c007 Mon Sep 17 00:00:00 2001 From: David Waern Date: Thu, 26 Aug 2010 21:40:59 +0000 Subject: Get rid of GhcModule and related cruft We can get everything we need directly from TypecheckedModule. --- src/Haddock/Interface.hs | 45 ++--------------------------------------- src/Haddock/Interface/Create.hs | 33 ++++++++++++++++-------------- src/Haddock/Types.hs | 23 --------------------- 3 files changed, 20 insertions(+), 81 deletions(-) (limited to 'src/Haddock') 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 @@ -350,29 +350,6 @@ data DocOption deriving (Eq, Show) ------------------------------------------------------------------------------ --- * 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 ----------------------------------------------------------------------------- -- cgit v1.2.3