diff options
Diffstat (limited to 'src/Haddock')
| -rw-r--r-- | src/Haddock/Interface.hs | 126 |
1 files changed, 75 insertions, 51 deletions
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index b25ed4ec..fbc2a7d3 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -27,7 +27,7 @@ -- using this environment. ----------------------------------------------------------------------------- module Haddock.Interface ( - createInterfaces + processModules ) where @@ -54,26 +54,27 @@ import GHC hiding (verbosity, flags) import HscTypes --- | Create 'Interface' structures by typechecking the list of modules --- using the GHC API and processing the resulting syntax trees. -createInterfaces - :: Verbosity -- ^ Verbosity of logging to 'stdout' - -> [String] -- ^ A list of file or module names sorted by module topology - -> [Flag] -- ^ Command-line flags - -> [InterfaceFile] -- ^ Interface files of package dependencies - -> Ghc ([Interface], LinkEnv) - -- ^ Resulting list of interfaces and renaming environment -createInterfaces verbosity modules flags extIfaces = do +-- | Create 'Interface's and a link environment by typechecking the list of +-- modules using the GHC API and processing the resulting syntax trees. +processModules + :: Verbosity -- ^ Verbosity of logging to 'stdout' + -> [String] -- ^ A list of file or module names sorted by + -- module topology + -> [Flag] -- ^ Command-line flags + -> [InterfaceFile] -- ^ Interface files of package dependencies + -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming + -- environment +processModules verbosity modules flags extIfaces = do out verbosity verbose "Creating interfaces..." let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ] - interfaces <- createInterfaces' verbosity modules flags instIfaceMap + interfaces <- createIfaces0 verbosity modules flags instIfaceMap out verbosity verbose "Attaching instances..." interfaces' <- attachInstances interfaces instIfaceMap - out verbosity verbose "Building link environment..." + out verbosity verbose "Building cross-linking 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 @@ -89,51 +90,58 @@ createInterfaces verbosity modules flags extIfaces = do return (interfaces'', homeLinks) -createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] -createInterfaces' verbosity modules flags instIfaceMap = do - let useTempDir = Flag_NoTmpCompDir `notElem` flags +-------------------------------------------------------------------------------- +-- * Module typechecking and Interface creation +-------------------------------------------------------------------------------- - -- Output dir needs to be set before calling depanal since it uses it to + +createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] +createIfaces0 verbosity modules flags instIfaceMap = + -- Output dir needs to be set before calling depanal since depanal uses it to -- compute output file names that are stored in the DynFlags of the -- resulting ModSummaries. - tmp <- liftIO getTemporaryDirectory - x <- liftIO getProcessID - let tempDir = tmp </> ".haddock-" ++ show x - when useTempDir $ modifySessionDynFlags (setOutputDir tempDir) - - targets <- mapM (\f -> guessTarget f Nothing) modules - setTargets targets - -- Dependency analysis. - modgraph <- depanal [] False - - -- If template haskell is used by the package, we can't use HscNothing as - -- target since we might need to run code generated from one or more of the - -- modules during typechecking. - if needsTemplateHaskell modgraph - then - -- Create a temporary directory in wich to write compilation output, - -- unless the user has asked us not to. - (if useTempDir then withTempDir tempDir else id) $ do - -- Turn on compilation. - let enableComp d = d { hscTarget = defaultObjectTarget } - modifySessionDynFlags enableComp - -- We need to update the DynFlags of the ModSummaries as well. - let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } - let modgraph' = map upd modgraph - - processModules verbosity flags instIfaceMap modgraph' - else - processModules verbosity flags instIfaceMap modgraph + (if useTempDir then withTempOutputDir else id) $ do + modGraph <- depAnalysis + if needsTemplateHaskell modGraph + then do + modGraph' <- enableCompilation modGraph + createIfaces verbosity flags instIfaceMap modGraph' + else + createIfaces verbosity flags instIfaceMap modGraph + where + useTempDir :: Bool + useTempDir = Flag_NoTmpCompDir `notElem` flags -withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a -withTempDir dir = gbracket_ (liftIO $ createDirectory dir) - (liftIO $ removeDirectoryRecursive dir) + + withTempOutputDir :: Ghc a -> Ghc a + withTempOutputDir action = do + tmp <- liftIO getTemporaryDirectory + x <- liftIO getProcessID + let dir = tmp </> ".haddock-" ++ show x + modifySessionDynFlags (setOutputDir dir) + withTempDir dir action + + + depAnalysis :: Ghc ModuleGraph + depAnalysis = do + targets <- mapM (\f -> guessTarget f Nothing) modules + setTargets targets + depanal [] False + + + enableCompilation :: ModuleGraph -> Ghc ModuleGraph + enableCompilation modGraph = do + let enableComp d = d { hscTarget = defaultObjectTarget } + modifySessionDynFlags enableComp + -- We need to update the DynFlags of the ModSummaries as well. + let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } + let modGraph' = map upd modGraph + return modGraph' -processModules :: Verbosity -> [Flag] -> InstIfaceMap -> [ModSummary] - -> Ghc [Interface] -processModules verbosity flags instIfaceMap mods = do +createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] +createIfaces verbosity flags instIfaceMap mods = do let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing (ifaces, _) <- foldM f ([], Map.empty) sortedMods return (reverse ifaces) @@ -200,6 +208,11 @@ mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule { (_, renamed, _, modInfo) = checkedMod +-------------------------------------------------------------------------------- +-- * Building of cross-linking environment +-------------------------------------------------------------------------------- + + -- | Build a mapping which for each original name, points to the "best" -- place to link to in the documentation. For the definition of -- "best", we use "the module nearest the bottom of the dependency @@ -221,3 +234,14 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env + + +-------------------------------------------------------------------------------- +-- * Utils +-------------------------------------------------------------------------------- + + +withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a +withTempDir dir = gbracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) + |