diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Haddock/GhcUtils.hs | 34 | ||||
| -rw-r--r-- | src/Haddock/Interface.hs | 86 | ||||
| -rw-r--r-- | src/Haddock/Options.hs | 5 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 50 |
4 files changed, 114 insertions, 61 deletions
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 1e3d366b..8c290f80 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -24,6 +24,7 @@ import Data.Traversable import Distribution.Compat.ReadP import Distribution.Text +import Exception import Outputable import Name import Packages @@ -227,3 +228,36 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] parents :: Name -> HsDecl Name -> [Name] parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] + + +------------------------------------------------------------------------------- +-- Utils that work in monads defined by GHC +------------------------------------------------------------------------------- + + +modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () +modifySessionDynFlags f = do + dflags <- getSessionDynFlags + _ <- setSessionDynFlags (f dflags) + return () + + +-- | A variant of 'gbracket' where the return value from the first computation +-- is not required. +gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c +gbracket_ before after thing = gbracket before (const after) (const thing) + + +------------------------------------------------------------------------------- +-- DynFlags +------------------------------------------------------------------------------- + + +setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags +setObjectDir f d = d{ objectDir = Just f} +setHiDir f d = d{ hiDir = Just f} +setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling with -fvia-C. +setOutputDir f = setObjectDir f . setHiDir f . setStubDir f + diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index c69a3423..22d55713 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -26,30 +26,31 @@ -- places to link to in the documentation, and all 'Interface's are \"renamed\" -- using this environment. ----------------------------------------------------------------------------- - module Haddock.Interface ( createInterfaces ) where +import Haddock.GhcUtils +import Haddock.InterfaceFile import Haddock.Interface.Create import Haddock.Interface.AttachInstances import Haddock.Interface.Rename -import Haddock.Types import Haddock.Options -import Haddock.GhcUtils +import Haddock.Types import Haddock.Utils -import Haddock.InterfaceFile -import qualified Data.Map as Map +import Control.Monad import Data.List +import qualified Data.Map as Map import Data.Maybe -import Control.Monad -import Control.Exception ( evaluate ) import Distribution.Verbosity +import System.Directory +import System.FilePath -import GHC hiding (verbosity, flags) import Digraph +import Exception +import GHC hiding (verbosity, flags) import HscTypes @@ -90,34 +91,61 @@ createInterfaces verbosity modules flags extIfaces = do createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] createInterfaces' verbosity modules flags instIfaceMap = do + let useTempDir = Flag_NoTmpCompDir `notElem` flags + + -- Output dir needs to be set before calling depanal since it 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 not use - -- HscNothing as target since we might need to run code generated from - -- one or more of the modules during typechecking. - modgraph' <- if needsTemplateHaskell modgraph - then do - dflags <- getSessionDynFlags - _ <- setSessionDynFlags dflags { hscTarget = defaultObjectTarget } - -- we need to set defaultObjectTarget on all the ModSummaries as well - let addDefTarget m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } } - return (map addDefTarget modgraph) - else return modgraph - - let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing - (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do - x <- processModule verbosity modsum flags modMap instIfaceMap - case x of - Just interface -> - return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap) - Nothing -> return (ifaces, modMap) - ) ([], Map.empty) orderedMods + -- 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 + + +withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a +withTempDir dir = gbracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) + + +processModules :: Verbosity -> [Flag] -> InstIfaceMap -> [ModSummary] + -> Ghc [Interface] +processModules verbosity flags instIfaceMap mods = do + let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing + (ifaces, _) <- foldM f ([], Map.empty) sortedMods return (reverse ifaces) + where + f (ifaces, ifaceMap) modSummary = do + x <- processModule verbosity modSummary flags ifaceMap instIfaceMap + return $ case x of + Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) + Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces. -processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface) +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 diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index e289ab65..8b1aa4aa 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -93,6 +93,7 @@ data Flag | Flag_PrintGhcLibDir | Flag_NoWarnings | Flag_UseUnicode + | Flag_NoTmpCompDir deriving (Eq) @@ -164,5 +165,7 @@ options backwardsCompat = "output GHC version in numeric format", Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) "output GHC lib dir", - Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings" + Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings", + Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir) + "don't re-direct compilation output to a temporary directory" ] diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 3c0b302c..b9795376 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -43,7 +43,10 @@ module Haddock.Utils ( -- * Logging parseVerbosity, - out + out, + + -- * System tools + getProcessID ) where @@ -69,6 +72,13 @@ import System.FilePath import Distribution.Verbosity import Distribution.ReadE +#ifndef mingw32_HOST_OS +import qualified System.Posix.Internals +#else /* Must be Win32 */ +import Foreign +import Foreign.C.String +#endif + import MonadUtils ( MonadIO(..) ) @@ -368,36 +378,14 @@ idMarkup = Markup { } ------------------------------------------------------------------------------ --- put here temporarily - - -newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) - - -nullFormatVersion :: FormatVersion -nullFormatVersion = mkFormatVersion 0 - +-- ----------------------------------------------------------------------------- +-- System tools -mkFormatVersion :: Int -> FormatVersion -mkFormatVersion = FormatVersion +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows +#else +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#endif -instance Binary FormatVersion where - put_ bh (FormatVersion i) = - case compare i 0 of - EQ -> return () - GT -> put_ bh (-i) - LT -> error ( - "Binary.hs: negative FormatVersion " ++ show i - ++ " is not allowed") - get bh = - do - (w8 :: Word8) <- get bh - if testBit w8 7 - then - do - i <- get bh - return (FormatVersion (-i)) - else - return nullFormatVersion |