Re-direct compilation output to a temporary directory

Also add a flag --no-tmp-comp-dir that can be used to get the old behaviour of
writing compilation files to GHC's output directory (default ".").

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