{-# LANGUAGE CPP #-}

-- | Temporary file-system management
module GHC.Utils.TmpFs
    ( TmpFs
    , initTmpFs
    , forkTmpFsFrom
    , mergeTmpFsInto
    , FilesToClean(..)
    , emptyFilesToClean
    , TempFileLifetime(..)
    , TempDir (..)
    , cleanTempDirs
    , cleanTempFiles
    , cleanCurrentModuleTempFiles
    , addFilesToClean
    , changeTempFilesLifetime
    , newTempName
    , newTempLibName
    , newTempDir
    , withSystemTempDirectory
    , withTempDirectory
    )
where

import GHC.Prelude

import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Logger
import GHC.Utils.Misc
import GHC.Utils.Exception as Exception
import GHC.Driver.Phases

import Data.List (partition)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Map as Map
import Data.Map (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

-- | Temporary file-system
data TmpFs = TmpFs
  { TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean :: IORef (Map FilePath FilePath)
      -- ^ Maps system temporary directory (passed via settings or DynFlags) to
      -- an actual temporary directory for this process.
      --
      -- It's a Map probably to support changing the system temporary directory
      -- over time.
      --
      -- Shared with forked TmpFs.

  , TmpFs -> IORef Int
tmp_next_suffix :: IORef Int
      -- ^ The next available suffix to uniquely name a temp file, updated
      -- atomically.
      --
      -- Shared with forked TmpFs.

  , TmpFs -> IORef FilesToClean
tmp_files_to_clean :: IORef FilesToClean
      -- ^ Files to clean (per session or per module)
      --
      -- Not shared with forked TmpFs.
  }

-- | A collection of files that must be deleted before ghc exits.
data FilesToClean = FilesToClean
    { FilesToClean -> Set FilePath
ftcGhcSession :: !(Set FilePath)
        -- ^ Files that will be deleted at the end of runGhc(T)

    , FilesToClean -> Set FilePath
ftcCurrentModule :: !(Set FilePath)
        -- ^ Files that will be deleted the next time
        -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of
        -- the session.
    }

-- | 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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TempFileLifetime] -> ShowS
$cshowList :: [TempFileLifetime] -> ShowS
show :: TempFileLifetime -> FilePath
$cshow :: TempFileLifetime -> FilePath
showsPrec :: Int -> TempFileLifetime -> ShowS
$cshowsPrec :: Int -> TempFileLifetime -> ShowS
Show)

newtype TempDir = TempDir FilePath

-- | An empty FilesToClean
emptyFilesToClean :: FilesToClean
emptyFilesToClean :: FilesToClean
emptyFilesToClean = Set FilePath -> Set FilePath -> FilesToClean
FilesToClean forall a. Set a
Set.empty forall a. Set a
Set.empty

-- | Merge two FilesToClean
mergeFilesToClean :: FilesToClean -> FilesToClean -> FilesToClean
mergeFilesToClean :: FilesToClean -> FilesToClean -> FilesToClean
mergeFilesToClean FilesToClean
x FilesToClean
y = FilesToClean
    { ftcGhcSession :: Set FilePath
ftcGhcSession    = forall a. Ord a => Set a -> Set a -> Set a
Set.union (FilesToClean -> Set FilePath
ftcGhcSession FilesToClean
x) (FilesToClean -> Set FilePath
ftcGhcSession FilesToClean
y)
    , ftcCurrentModule :: Set FilePath
ftcCurrentModule = forall a. Ord a => Set a -> Set a -> Set a
Set.union (FilesToClean -> Set FilePath
ftcCurrentModule FilesToClean
x) (FilesToClean -> Set FilePath
ftcCurrentModule FilesToClean
y)
    }

-- | Initialise an empty TmpFs
initTmpFs :: IO TmpFs
initTmpFs :: IO TmpFs
initTmpFs = do
    IORef FilesToClean
files <- forall a. a -> IO (IORef a)
newIORef FilesToClean
emptyFilesToClean
    IORef (Map FilePath FilePath)
dirs  <- forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
Map.empty
    IORef Int
next  <- forall a. a -> IO (IORef a)
newIORef Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TmpFs
        { tmp_files_to_clean :: IORef FilesToClean
tmp_files_to_clean = IORef FilesToClean
files
        , tmp_dirs_to_clean :: IORef (Map FilePath FilePath)
tmp_dirs_to_clean  = IORef (Map FilePath FilePath)
dirs
        , tmp_next_suffix :: IORef Int
tmp_next_suffix    = IORef Int
next
        }

-- | Initialise an empty TmpFs sharing unique numbers and per-process temporary
-- directories with the given TmpFs
forkTmpFsFrom :: TmpFs -> IO TmpFs
forkTmpFsFrom :: TmpFs -> IO TmpFs
forkTmpFsFrom TmpFs
old = do
    IORef FilesToClean
files <- forall a. a -> IO (IORef a)
newIORef FilesToClean
emptyFilesToClean
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TmpFs
        { tmp_files_to_clean :: IORef FilesToClean
tmp_files_to_clean = IORef FilesToClean
files
        , tmp_dirs_to_clean :: IORef (Map FilePath FilePath)
tmp_dirs_to_clean  = TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean TmpFs
old
        , tmp_next_suffix :: IORef Int
tmp_next_suffix    = TmpFs -> IORef Int
tmp_next_suffix TmpFs
old
        }

-- | Merge the first TmpFs into the second.
--
-- The first TmpFs is returned emptied.
mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()
mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()
mergeTmpFsInto TmpFs
src TmpFs
dst = do
    FilesToClean
src_files <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef FilesToClean
tmp_files_to_clean TmpFs
src) (\FilesToClean
s -> (FilesToClean
emptyFilesToClean, FilesToClean
s))
    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef FilesToClean
tmp_files_to_clean TmpFs
dst) (\FilesToClean
s -> (FilesToClean -> FilesToClean -> FilesToClean
mergeFilesToClean FilesToClean
src_files FilesToClean
s, ()))

cleanTempDirs :: Logger -> TmpFs -> IO ()
cleanTempDirs :: Logger -> TmpFs -> IO ()
cleanTempDirs Logger
logger TmpFs
tmpfs
   = forall a. IO a -> IO a
mask_
   forall a b. (a -> b) -> a -> b
$ do let ref :: IORef (Map FilePath FilePath)
ref = TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean TmpFs
tmpfs
        Map FilePath FilePath
ds <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map FilePath FilePath)
ref forall a b. (a -> b) -> a -> b
$ \Map FilePath FilePath
ds -> (forall k a. Map k a
Map.empty, Map FilePath FilePath
ds)
        Logger -> [FilePath] -> IO ()
removeTmpDirs Logger
logger (forall k a. Map k a -> [a]
Map.elems Map FilePath FilePath
ds)

-- | Delete all files in @tmp_files_to_clean@.
cleanTempFiles :: Logger -> TmpFs -> IO ()
cleanTempFiles :: Logger -> TmpFs -> IO ()
cleanTempFiles Logger
logger TmpFs
tmpfs
   = forall a. IO a -> IO a
mask_
   forall a b. (a -> b) -> a -> b
$ do let ref :: IORef FilesToClean
ref = TmpFs -> IORef FilesToClean
tmp_files_to_clean TmpFs
tmpfs
        [FilePath]
to_delete <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FilesToClean
ref forall a b. (a -> b) -> a -> b
$
            \FilesToClean
                { ftcCurrentModule :: FilesToClean -> Set FilePath
ftcCurrentModule = Set FilePath
cm_files
                , ftcGhcSession :: FilesToClean -> Set FilePath
ftcGhcSession = Set FilePath
gs_files
                } -> ( FilesToClean
emptyFilesToClean
                     , forall a. Set a -> [a]
Set.toList Set FilePath
cm_files forall a. [a] -> [a] -> [a]
++ forall a. Set a -> [a]
Set.toList Set FilePath
gs_files)
        Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger [FilePath]
to_delete

-- | Delete all files in @tmp_files_to_clean@. That have lifetime
-- TFL_CurrentModule.
-- If a file must be cleaned eventually, but must survive a
-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
   = forall a. IO a -> IO a
mask_
   forall a b. (a -> b) -> a -> b
$ do let ref :: IORef FilesToClean
ref = TmpFs -> IORef FilesToClean
tmp_files_to_clean TmpFs
tmpfs
        [FilePath]
to_delete <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FilesToClean
ref forall a b. (a -> b) -> a -> b
$
            \ftc :: FilesToClean
ftc@FilesToClean{ftcCurrentModule :: FilesToClean -> Set FilePath
ftcCurrentModule = Set FilePath
cm_files} ->
                (FilesToClean
ftc {ftcCurrentModule :: Set FilePath
ftcCurrentModule = forall a. Set a
Set.empty}, forall a. Set a -> [a]
Set.toList Set FilePath
cm_files)
        Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger [FilePath]
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 :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
lifetime [FilePath]
new_files = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (TmpFs -> IORef FilesToClean
tmp_files_to_clean TmpFs
tmpfs) forall a b. (a -> b) -> a -> b
$
  \FilesToClean
    { ftcCurrentModule :: FilesToClean -> Set FilePath
ftcCurrentModule = Set FilePath
cm_files
    , ftcGhcSession :: FilesToClean -> Set FilePath
ftcGhcSession = Set FilePath
gs_files
    } -> case TempFileLifetime
lifetime of
      TempFileLifetime
TFL_CurrentModule -> FilesToClean
        { ftcCurrentModule :: Set FilePath
ftcCurrentModule = Set FilePath
cm_files forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set FilePath
new_files_set
        , ftcGhcSession :: Set FilePath
ftcGhcSession = Set FilePath
gs_files forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
new_files_set
        }
      TempFileLifetime
TFL_GhcSession -> FilesToClean
        { ftcCurrentModule :: Set FilePath
ftcCurrentModule = Set FilePath
cm_files forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
new_files_set
        , ftcGhcSession :: Set FilePath
ftcGhcSession = Set FilePath
gs_files forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set FilePath
new_files_set
        }
  where
    new_files_set :: Set FilePath
new_files_set = forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
new_files

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

-- Return a unique numeric temp file suffix
newTempSuffix :: TmpFs -> IO Int
newTempSuffix :: TmpFs -> IO Int
newTempSuffix TmpFs
tmpfs =
  forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef Int
tmp_next_suffix TmpFs
tmpfs) forall a b. (a -> b) -> a -> b
$ \Int
n -> (Int
nforall a. Num a => a -> a -> a
+Int
1,Int
n)

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

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

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


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

    mkTempDir :: FilePath -> IO FilePath
    mkTempDir :: FilePath -> IO FilePath
mkTempDir FilePath
prefix = do
        Int
n <- TmpFs -> IO Int
newTempSuffix TmpFs
tmpfs
        let our_dir :: FilePath
our_dir = FilePath
prefix forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
n

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

        -- 2. Update the tmp_dirs_to_clean mapping unless an entry already exists
        -- (i.e. unless another thread beat us to it).
        Maybe FilePath
their_dir <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map FilePath FilePath)
dir_ref forall a b. (a -> b) -> a -> b
$ \Map FilePath FilePath
mapping ->
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
tmp_dir Map FilePath FilePath
mapping of
                Just FilePath
dir -> (Map FilePath FilePath
mapping, forall a. a -> Maybe a
Just FilePath
dir)
                Maybe FilePath
Nothing  -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
tmp_dir FilePath
our_dir Map FilePath FilePath
mapping, 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 FilePath
their_dir of
            Maybe FilePath
Nothing  -> do
                Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 forall a b. (a -> b) -> a -> b
$
                    forall doc. IsLine doc => FilePath -> doc
text FilePath
"Created temporary directory:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
our_dir
                forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
our_dir
            Just FilePath
dir -> do
                FilePath -> IO ()
removeDirectory FilePath
our_dir
                forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
      forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO` \IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
                      then FilePath -> IO FilePath
mkTempDir FilePath
prefix else 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 :: Logger -> [FilePath] -> IO ()
removeTmpDirs :: Logger -> [FilePath] -> IO ()
removeTmpDirs Logger
logger [FilePath]
ds
  = forall a. Logger -> FilePath -> FilePath -> IO a -> IO a
traceCmd Logger
logger FilePath
"Deleting temp dirs"
             (FilePath
"Deleting: " forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
ds)
             (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith Logger
logger FilePath -> IO ()
removeDirectory) [FilePath]
ds)

removeTmpFiles :: Logger -> [FilePath] -> IO ()
removeTmpFiles :: Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger [FilePath]
fs
  = IO () -> IO ()
warnNon forall a b. (a -> b) -> a -> b
$
    forall a. Logger -> FilePath -> FilePath -> IO a -> IO a
traceCmd Logger
logger FilePath
"Deleting temp files"
             (FilePath
"Deleting: " forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
deletees)
             (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith Logger
logger FilePath -> IO ()
removeFile) [FilePath]
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 () -> IO ()
warnNon IO ()
act
     | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
non_deletees = IO ()
act
     | Bool
otherwise         = do
        Logger -> SDoc -> IO ()
putMsg Logger
logger (forall doc. IsLine doc => FilePath -> doc
text FilePath
"WARNING - NOT deleting source files:"
                   forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => [doc] -> doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall doc. IsLine doc => FilePath -> doc
text [FilePath]
non_deletees))
        IO ()
act

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

removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith Logger
logger FilePath -> IO ()
remover FilePath
f = FilePath -> IO ()
remover FilePath
f forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO`
  (\IOException
e ->
   let msg :: SDoc
msg = if IOException -> Bool
isDoesNotExistError IOException
e
             then forall doc. IsLine doc => FilePath -> doc
text FilePath
"Warning: deleting non-existent" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
f
             else forall doc. IsLine doc => FilePath -> doc
text FilePath
"Warning: exception raised when deleting"
                                            forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
f forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon
               forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsLine doc => FilePath -> doc
text (forall a. Show a => a -> FilePath
show IOException
e)
   in Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 SDoc
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. FilePath -> (FilePath -> IO a) -> IO a
withSystemTempDirectory FilePath
template FilePath -> IO a
action =
  IO FilePath
getTemporaryDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
tmpDir -> forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory FilePath
tmpDir FilePath
template FilePath -> 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 :: forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory FilePath
targetDir FilePath
template =
  forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
    (FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
targetDir FilePath
template)
    (IO () -> IO ()
ignoringIOErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
removeDirectoryRecursive)

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


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