{-# LANGUAGE CPP #-}
module FileCleanup
  ( TempFileLifetime(..)
  , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
  , addFilesToClean, changeTempFilesLifetime
  , newTempName, newTempLibName, newTempDir
  , withSystemTempDirectory, withTempDirectory
  ) where

import GhcPrelude

import DynFlags
import ErrUtils
import Outputable
import Util
import Exception
import DriverPhases

import Control.Monad
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.IORef
import System.Directory
import System.FilePath
import System.IO.Error

#if !defined(mingw32_HOST_OS)
import qualified System.Posix.Internals
#endif

-- | Used when a temp file is created. This determines which component Set of
-- FilesToClean will get the temp file
data TempFileLifetime
  = TFL_CurrentModule
  -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the
  -- end of upweep_mod
  | TFL_GhcSession
  -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of
  -- runGhc(T)
  deriving (Int -> TempFileLifetime -> ShowS
[TempFileLifetime] -> ShowS
TempFileLifetime -> String
(Int -> TempFileLifetime -> ShowS)
-> (TempFileLifetime -> String)
-> ([TempFileLifetime] -> ShowS)
-> Show TempFileLifetime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TempFileLifetime] -> ShowS
$cshowList :: [TempFileLifetime] -> ShowS
show :: TempFileLifetime -> String
$cshow :: TempFileLifetime -> String
showsPrec :: Int -> TempFileLifetime -> ShowS
$cshowsPrec :: Int -> TempFileLifetime -> ShowS
Show)

cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags :: DynFlags
dflags
   = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags)
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
mask_
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do let ref :: IORef (Map String String)
ref = DynFlags -> IORef (Map String String)
dirsToClean DynFlags
dflags
        Map String String
ds <- IORef (Map String String)
-> (Map String String -> (Map String String, Map String String))
-> IO (Map String String)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map String String)
ref ((Map String String -> (Map String String, Map String String))
 -> IO (Map String String))
-> (Map String String -> (Map String String, Map String String))
-> IO (Map String String)
forall a b. (a -> b) -> a -> b
$ \ds :: Map String String
ds -> (Map String String
forall k a. Map k a
Map.empty, Map String String
ds)
        DynFlags -> [String] -> IO ()
removeTmpDirs DynFlags
dflags (Map String String -> [String]
forall k a. Map k a -> [a]
Map.elems Map String String
ds)

-- | Delete all files in @filesToClean dflags@.
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags :: DynFlags
dflags
   = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags)
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
mask_
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do let ref :: IORef FilesToClean
ref = DynFlags -> IORef FilesToClean
filesToClean DynFlags
dflags
        [String]
to_delete <- IORef FilesToClean
-> (FilesToClean -> (FilesToClean, [String])) -> IO [String]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FilesToClean
ref ((FilesToClean -> (FilesToClean, [String])) -> IO [String])
-> (FilesToClean -> (FilesToClean, [String])) -> IO [String]
forall a b. (a -> b) -> a -> b
$
            \FilesToClean
                { ftcCurrentModule :: FilesToClean -> Set String
ftcCurrentModule = Set String
cm_files
                , ftcGhcSession :: FilesToClean -> Set String
ftcGhcSession = Set String
gs_files
                } -> ( FilesToClean
emptyFilesToClean
                     , Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
cm_files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
gs_files)
        DynFlags -> [String] -> IO ()
removeTmpFiles DynFlags
dflags [String]
to_delete

-- | Delete all files in @filesToClean dflags@. That have lifetime
-- TFL_CurrentModule.
-- If a file must be cleaned eventually, but must survive a
-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
cleanCurrentModuleTempFiles :: DynFlags -> IO ()
cleanCurrentModuleTempFiles :: DynFlags -> IO ()
cleanCurrentModuleTempFiles dflags :: DynFlags
dflags
   = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags)
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
mask_
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do let ref :: IORef FilesToClean
ref = DynFlags -> IORef FilesToClean
filesToClean DynFlags
dflags
        [String]
to_delete <- IORef FilesToClean
-> (FilesToClean -> (FilesToClean, [String])) -> IO [String]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FilesToClean
ref ((FilesToClean -> (FilesToClean, [String])) -> IO [String])
-> (FilesToClean -> (FilesToClean, [String])) -> IO [String]
forall a b. (a -> b) -> a -> b
$
            \ftc :: FilesToClean
ftc@FilesToClean{ftcCurrentModule :: FilesToClean -> Set String
ftcCurrentModule = Set String
cm_files} ->
                (FilesToClean
ftc {ftcCurrentModule :: Set String
ftcCurrentModule = Set String
forall a. Set a
Set.empty}, Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
cm_files)
        DynFlags -> [String] -> IO ()
removeTmpFiles DynFlags
dflags [String]
to_delete

-- | Ensure that new_files are cleaned on the next call of
-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.
-- If any of new_files are already tracked, they will have their lifetime
-- updated.
addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean :: DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean dflags :: DynFlags
dflags lifetime :: TempFileLifetime
lifetime new_files :: [String]
new_files = IORef FilesToClean -> (FilesToClean -> FilesToClean) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (DynFlags -> IORef FilesToClean
filesToClean DynFlags
dflags) ((FilesToClean -> FilesToClean) -> IO ())
-> (FilesToClean -> FilesToClean) -> IO ()
forall a b. (a -> b) -> a -> b
$
  \FilesToClean
    { ftcCurrentModule :: FilesToClean -> Set String
ftcCurrentModule = Set String
cm_files
    , ftcGhcSession :: FilesToClean -> Set String
ftcGhcSession = Set String
gs_files
    } -> case TempFileLifetime
lifetime of
      TFL_CurrentModule -> $WFilesToClean :: Set String -> Set String -> FilesToClean
FilesToClean
        { ftcCurrentModule :: Set String
ftcCurrentModule = Set String
cm_files Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set String
new_files_set
        , ftcGhcSession :: Set String
ftcGhcSession = Set String
gs_files Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
new_files_set
        }
      TFL_GhcSession -> $WFilesToClean :: Set String -> Set String -> FilesToClean
FilesToClean
        { ftcCurrentModule :: Set String
ftcCurrentModule = Set String
cm_files Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
new_files_set
        , ftcGhcSession :: Set String
ftcGhcSession = Set String
gs_files Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set String
new_files_set
        }
  where
    new_files_set :: Set String
new_files_set = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
new_files

-- | Update the lifetime of files already being tracked. If any files are
-- not being tracked they will be discarded.
changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [String] -> IO ()
changeTempFilesLifetime dflags :: DynFlags
dflags lifetime :: TempFileLifetime
lifetime files :: [String]
files = do
  FilesToClean
    { ftcCurrentModule :: FilesToClean -> Set String
ftcCurrentModule = Set String
cm_files
    , ftcGhcSession :: FilesToClean -> Set String
ftcGhcSession = Set String
gs_files
    } <- IORef FilesToClean -> IO FilesToClean
forall a. IORef a -> IO a
readIORef (DynFlags -> IORef FilesToClean
filesToClean DynFlags
dflags)
  let old_set :: Set String
old_set = case TempFileLifetime
lifetime of
        TFL_CurrentModule -> Set String
gs_files
        TFL_GhcSession -> Set String
cm_files
      existing_files :: [String]
existing_files = [String
f | String
f <- [String]
files, String
f String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
old_set]
  DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
lifetime [String]
existing_files

-- Return a unique numeric temp file suffix
newTempSuffix :: DynFlags -> IO Int
newTempSuffix :: DynFlags -> IO Int
newTempSuffix dflags :: DynFlags
dflags =
  IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (DynFlags -> IORef Int
nextTempSuffix DynFlags
dflags) ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \n :: Int
n -> (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1,Int
n)

-- Find a temporary name that doesn't already exist.
newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath
newTempName :: DynFlags -> TempFileLifetime -> String -> IO String
newTempName dflags :: DynFlags
dflags lifetime :: TempFileLifetime
lifetime extn :: String
extn
  = do String
d <- DynFlags -> IO String
getTempDir DynFlags
dflags
       String -> IO String
findTempName (String
d String -> ShowS
</> "ghc_") -- See Note [Deterministic base name]
  where
    findTempName :: FilePath -> IO FilePath
    findTempName :: String -> IO String
findTempName prefix :: String
prefix
      = do Int
n <- DynFlags -> IO Int
newTempSuffix DynFlags
dflags
           let filename :: String
filename = String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
<.> String
extn
           Bool
b <- String -> IO Bool
doesFileExist String
filename
           if Bool
b then String -> IO String
findTempName String
prefix
                else do -- clean it up later
                        DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
lifetime [String
filename]
                        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
filename

newTempDir :: DynFlags -> IO FilePath
newTempDir :: DynFlags -> IO String
newTempDir dflags :: DynFlags
dflags
  = do String
d <- DynFlags -> IO String
getTempDir DynFlags
dflags
       String -> IO String
findTempDir (String
d String -> ShowS
</> "ghc_")
  where
    findTempDir :: FilePath -> IO FilePath
    findTempDir :: String -> IO String
findTempDir prefix :: String
prefix
      = do Int
n <- DynFlags -> IO Int
newTempSuffix DynFlags
dflags
           let filename :: String
filename = String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
           Bool
b <- String -> IO Bool
doesDirectoryExist String
filename
           if Bool
b then String -> IO String
findTempDir String
prefix
                else do String -> IO ()
createDirectory String
filename
                        -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename
                        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
filename

newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
  -> IO (FilePath, FilePath, String)
newTempLibName :: DynFlags
-> TempFileLifetime -> String -> IO (String, String, String)
newTempLibName dflags :: DynFlags
dflags lifetime :: TempFileLifetime
lifetime extn :: String
extn
  = do String
d <- DynFlags -> IO String
getTempDir DynFlags
dflags
       String -> String -> IO (String, String, String)
findTempName String
d ("ghc_")
  where
    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
    findTempName :: String -> String -> IO (String, String, String)
findTempName dir :: String
dir prefix :: String
prefix
      = do Int
n <- DynFlags -> IO Int
newTempSuffix DynFlags
dflags -- See Note [Deterministic base name]
           let libname :: String
libname = String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
               filename :: String
filename = String
dir String -> ShowS
</> "lib" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
libname String -> ShowS
<.> String
extn
           Bool
b <- String -> IO Bool
doesFileExist String
filename
           if Bool
b then String -> String -> IO (String, String, String)
findTempName String
dir String
prefix
                else do -- clean it up later
                        DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
lifetime [String
filename]
                        (String, String, String) -> IO (String, String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
filename, String
dir, String
libname)


-- Return our temporary directory within tmp_dir, creating one if we
-- don't have one yet.
getTempDir :: DynFlags -> IO FilePath
getTempDir :: DynFlags -> IO String
getTempDir dflags :: DynFlags
dflags = do
    Map String String
mapping <- IORef (Map String String) -> IO (Map String String)
forall a. IORef a -> IO a
readIORef IORef (Map String String)
dir_ref
    case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
tmp_dir Map String String
mapping of
        Nothing -> do
            Int
pid <- IO Int
getProcessID
            let prefix :: String
prefix = String
tmp_dir String -> ShowS
</> "ghc" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pid String -> ShowS
forall a. [a] -> [a] -> [a]
++ "_"
            IO String -> IO String
forall a. IO a -> IO a
mask_ (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
mkTempDir String
prefix
        Just dir :: String
dir -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir
  where
    tmp_dir :: String
tmp_dir = DynFlags -> String
tmpDir DynFlags
dflags
    dir_ref :: IORef (Map String String)
dir_ref = DynFlags -> IORef (Map String String)
dirsToClean DynFlags
dflags

    mkTempDir :: FilePath -> IO FilePath
    mkTempDir :: String -> IO String
mkTempDir prefix :: String
prefix = do
        Int
n <- DynFlags -> IO Int
newTempSuffix DynFlags
dflags
        let our_dir :: String
our_dir = String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

        -- 1. Speculatively create our new directory.
        String -> IO ()
createDirectory String
our_dir

        -- 2. Update the dirsToClean mapping unless an entry already exists
        -- (i.e. unless another thread beat us to it).
        Maybe String
their_dir <- IORef (Map String String)
-> (Map String String -> (Map String String, Maybe String))
-> IO (Maybe String)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map String String)
dir_ref ((Map String String -> (Map String String, Maybe String))
 -> IO (Maybe String))
-> (Map String String -> (Map String String, Maybe String))
-> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \mapping :: Map String String
mapping ->
            case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
tmp_dir Map String String
mapping of
                Just dir :: String
dir -> (Map String String
mapping, String -> Maybe String
forall a. a -> Maybe a
Just String
dir)
                Nothing  -> (String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
tmp_dir String
our_dir Map String String
mapping, Maybe String
forall a. Maybe a
Nothing)

        -- 3. If there was an existing entry, return it and delete the
        -- directory we created.  Otherwise return the directory we created.
        case Maybe String
their_dir of
            Nothing  -> do
                DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> MsgDoc
text "Created temporary directory:" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
our_dir
                String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
our_dir
            Just dir :: String
dir -> do
                String -> IO ()
removeDirectory String
our_dir
                String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir
      IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \e :: IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
                      then String -> IO String
mkTempDir String
prefix else IOException -> IO String
forall a. IOException -> IO a
ioError IOException
e

{- Note [Deterministic base name]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The filename of temporary files, especially the basename of C files, can end
up in the output in some form, e.g. as part of linker debug information. In the
interest of bit-wise exactly reproducible compilation (#4012), the basename of
the temporary file no longer contains random information (it used to contain
the process id).

This is ok, as the temporary directory used contains the pid (see getTempDir).
-}
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs :: DynFlags -> [String] -> IO ()
removeTmpDirs dflags :: DynFlags
dflags ds :: [String]
ds
  = DynFlags -> String -> String -> IO () -> IO ()
forall a. DynFlags -> String -> String -> IO a -> IO a
traceCmd DynFlags
dflags "Deleting temp dirs"
             ("Deleting: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ds)
             ((String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> (String -> IO ()) -> String -> IO ()
removeWith DynFlags
dflags String -> IO ()
removeDirectory) [String]
ds)

removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles :: DynFlags -> [String] -> IO ()
removeTmpFiles dflags :: DynFlags
dflags fs :: [String]
fs
  = IO () -> IO ()
forall a. IO a -> IO a
warnNon (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DynFlags -> String -> String -> IO () -> IO ()
forall a. DynFlags -> String -> String -> IO a -> IO a
traceCmd DynFlags
dflags "Deleting temp files"
             ("Deleting: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
deletees)
             ((String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> (String -> IO ()) -> String -> IO ()
removeWith DynFlags
dflags String -> IO ()
removeFile) [String]
deletees)
  where
     -- Flat out refuse to delete files that are likely to be source input
     -- files (is there a worse bug than having a compiler delete your source
     -- files?)
     --
     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
     -- the condition.
    warnNon :: IO b -> IO b
warnNon act :: IO b
act
     | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
non_deletees = IO b
act
     | Bool
otherwise         = do
        DynFlags -> MsgDoc -> IO ()
putMsg DynFlags
dflags (String -> MsgDoc
text "WARNING - NOT deleting source files:"
                       MsgDoc -> MsgDoc -> MsgDoc
<+> [MsgDoc] -> MsgDoc
hsep ((String -> MsgDoc) -> [String] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> MsgDoc
text [String]
non_deletees))
        IO b
act

    (non_deletees :: [String]
non_deletees, deletees :: [String]
deletees) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
isHaskellUserSrcFilename [String]
fs

removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith :: DynFlags -> (String -> IO ()) -> String -> IO ()
removeWith dflags :: DynFlags
dflags remover :: String -> IO ()
remover f :: String
f = String -> IO ()
remover String
f IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO`
  (\e :: IOException
e ->
   let msg :: MsgDoc
msg = if IOException -> Bool
isDoesNotExistError IOException
e
             then String -> MsgDoc
text "Warning: deleting non-existent" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
f
             else String -> MsgDoc
text "Warning: exception raised when deleting"
                                            MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
f MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
               MsgDoc -> MsgDoc -> MsgDoc
$$ String -> MsgDoc
text (IOException -> String
forall a. Show a => a -> String
show IOException
e)
   in DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 MsgDoc
msg
  )

#if defined(mingw32_HOST_OS)
-- relies on Int == Int32 on Windows
foreign import ccall unsafe "_getpid" getProcessID :: IO Int
#else
getProcessID :: IO Int
getProcessID :: IO Int
getProcessID = IO CPid
System.Posix.Internals.c_getpid IO CPid -> (CPid -> IO Int) -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (CPid -> Int) -> CPid -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPid -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
#endif

-- The following three functions are from the `temporary` package.

-- | Create and use a temporary directory in the system standard temporary
-- directory.
--
-- Behaves exactly the same as 'withTempDirectory', except that the parent
-- temporary directory will be that returned by 'getTemporaryDirectory'.
withSystemTempDirectory :: String   -- ^ Directory name template. See 'openTempFile'.
                        -> (FilePath -> IO a) -- ^ Callback that can use the directory
                        -> IO a
withSystemTempDirectory :: String -> (String -> IO a) -> IO a
withSystemTempDirectory template :: String
template action :: String -> IO a
action =
  IO String
getTemporaryDirectory IO String -> (String -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \tmpDir :: String
tmpDir -> String -> String -> (String -> IO a) -> IO a
forall a. String -> String -> (String -> IO a) -> IO a
withTempDirectory String
tmpDir String
template String -> IO a
action


-- | Create and use a temporary directory.
--
-- Creates a new temporary directory inside the given directory, making use
-- of the template. The temp directory is deleted after use. For example:
--
-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...
--
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
-- @src/sdist.342@.
withTempDirectory :: FilePath -- ^ Temp directory to create the directory in
                  -> String   -- ^ Directory name template. See 'openTempFile'.
                  -> (FilePath -> IO a) -- ^ Callback that can use the directory
                  -> IO a
withTempDirectory :: String -> String -> (String -> IO a) -> IO a
withTempDirectory targetDir :: String
targetDir template :: String
template =
  IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
    (String -> String -> IO String
createTempDirectory String
targetDir String
template)
    (IO () -> IO ()
ignoringIOErrors (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeDirectoryRecursive)

ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors ioe :: IO ()
ioe = IO ()
ioe IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\e :: IOException
e -> IO () -> IOException -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IOException
e :: IOError))


createTempDirectory :: FilePath -> String -> IO FilePath
createTempDirectory :: String -> String -> IO String
createTempDirectory dir :: String
dir template :: String
template = do
  Int
pid <- IO Int
getProcessID
  Int -> IO String
forall a. (Num a, Show a) => a -> IO String
findTempName Int
pid
  where findTempName :: a -> IO String
findTempName x :: a
x = do
            let path :: String
path = String
dir String -> ShowS
</> String
template String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
            String -> IO ()
createDirectory String
path
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
          IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \e :: IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
                          then a -> IO String
findTempName (a
xa -> a -> a
forall a. Num a => a -> a -> a
+1) else IOException -> IO String
forall a. IOException -> IO a
ioError IOException
e