aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/GhcUtils.hs34
-rw-r--r--src/Haddock/Interface.hs86
-rw-r--r--src/Haddock/Options.hs5
-rw-r--r--src/Haddock/Utils.hs50
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 20:47:29 +0000