{-# LANGUAGE CPP #-}
module GHC.Utils.TmpFs
( TmpFs
, initTmpFs
, forkTmpFsFrom
, mergeTmpFsInto
, PathsToClean(..)
, emptyPathsToClean
, TempFileLifetime(..)
, TempDir (..)
, cleanTempDirs
, cleanTempFiles
, cleanCurrentModuleTempFiles
, keepCurrentModuleTempFiles
, addFilesToClean
, changeTempFilesLifetime
, newTempName
, newTempLibName
, newTempSubDir
, 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
data TmpFs = TmpFs
{ TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean :: IORef (Map FilePath FilePath)
, TmpFs -> IORef Int
tmp_next_suffix :: IORef Int
, TmpFs -> IORef PathsToClean
tmp_files_to_clean :: IORef PathsToClean
, TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean :: IORef PathsToClean
}
data PathsToClean = PathsToClean
{ PathsToClean -> Set FilePath
ptcGhcSession :: !(Set FilePath)
, PathsToClean -> Set FilePath
ptcCurrentModule :: !(Set FilePath)
}
data TempFileLifetime
= TFL_CurrentModule
| TFL_GhcSession
deriving (Int -> TempFileLifetime -> ShowS
[TempFileLifetime] -> ShowS
TempFileLifetime -> FilePath
(Int -> TempFileLifetime -> ShowS)
-> (TempFileLifetime -> FilePath)
-> ([TempFileLifetime] -> ShowS)
-> Show TempFileLifetime
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TempFileLifetime -> ShowS
showsPrec :: Int -> TempFileLifetime -> ShowS
$cshow :: TempFileLifetime -> FilePath
show :: TempFileLifetime -> FilePath
$cshowList :: [TempFileLifetime] -> ShowS
showList :: [TempFileLifetime] -> ShowS
Show)
newtype TempDir = TempDir FilePath
emptyPathsToClean :: PathsToClean
emptyPathsToClean :: PathsToClean
emptyPathsToClean = Set FilePath -> Set FilePath -> PathsToClean
PathsToClean Set FilePath
forall a. Set a
Set.empty Set FilePath
forall a. Set a
Set.empty
mergePathsToClean :: PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean :: PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean PathsToClean
x PathsToClean
y = PathsToClean
{ ptcGhcSession :: Set FilePath
ptcGhcSession = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.union (PathsToClean -> Set FilePath
ptcGhcSession PathsToClean
x) (PathsToClean -> Set FilePath
ptcGhcSession PathsToClean
y)
, ptcCurrentModule :: Set FilePath
ptcCurrentModule = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.union (PathsToClean -> Set FilePath
ptcCurrentModule PathsToClean
x) (PathsToClean -> Set FilePath
ptcCurrentModule PathsToClean
y)
}
initTmpFs :: IO TmpFs
initTmpFs :: IO TmpFs
initTmpFs = do
IORef PathsToClean
files <- PathsToClean -> IO (IORef PathsToClean)
forall a. a -> IO (IORef a)
newIORef PathsToClean
emptyPathsToClean
IORef PathsToClean
subdirs <- PathsToClean -> IO (IORef PathsToClean)
forall a. a -> IO (IORef a)
newIORef PathsToClean
emptyPathsToClean
IORef (Map FilePath FilePath)
dirs <- Map FilePath FilePath -> IO (IORef (Map FilePath FilePath))
forall a. a -> IO (IORef a)
newIORef Map FilePath FilePath
forall k a. Map k a
Map.empty
IORef Int
next <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
TmpFs -> IO TmpFs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TmpFs -> IO TmpFs) -> TmpFs -> IO TmpFs
forall a b. (a -> b) -> a -> b
$ TmpFs
{ tmp_files_to_clean :: IORef PathsToClean
tmp_files_to_clean = IORef PathsToClean
files
, tmp_subdirs_to_clean :: IORef PathsToClean
tmp_subdirs_to_clean = IORef PathsToClean
subdirs
, 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
}
forkTmpFsFrom :: TmpFs -> IO TmpFs
forkTmpFsFrom :: TmpFs -> IO TmpFs
forkTmpFsFrom TmpFs
old = do
IORef PathsToClean
files <- PathsToClean -> IO (IORef PathsToClean)
forall a. a -> IO (IORef a)
newIORef PathsToClean
emptyPathsToClean
IORef PathsToClean
subdirs <- PathsToClean -> IO (IORef PathsToClean)
forall a. a -> IO (IORef a)
newIORef PathsToClean
emptyPathsToClean
TmpFs -> IO TmpFs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TmpFs -> IO TmpFs) -> TmpFs -> IO TmpFs
forall a b. (a -> b) -> a -> b
$ TmpFs
{ tmp_files_to_clean :: IORef PathsToClean
tmp_files_to_clean = IORef PathsToClean
files
, tmp_subdirs_to_clean :: IORef PathsToClean
tmp_subdirs_to_clean = IORef PathsToClean
subdirs
, 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
}
mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()
mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()
mergeTmpFsInto TmpFs
src TmpFs
dst = do
PathsToClean
src_files <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, PathsToClean))
-> IO PathsToClean
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
src) (\PathsToClean
s -> (PathsToClean
emptyPathsToClean, PathsToClean
s))
PathsToClean
src_subdirs <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, PathsToClean))
-> IO PathsToClean
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
src) (\PathsToClean
s -> (PathsToClean
emptyPathsToClean, PathsToClean
s))
IORef PathsToClean -> (PathsToClean -> (PathsToClean, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
dst) (\PathsToClean
s -> (PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean PathsToClean
src_files PathsToClean
s, ()))
IORef PathsToClean -> (PathsToClean -> (PathsToClean, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
dst) (\PathsToClean
s -> (PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean PathsToClean
src_subdirs PathsToClean
s, ()))
cleanTempDirs :: Logger -> TmpFs -> IO ()
cleanTempDirs :: Logger -> TmpFs -> IO ()
cleanTempDirs Logger
logger TmpFs
tmpfs
= 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 FilePath FilePath)
ref = TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean TmpFs
tmpfs
Map FilePath FilePath
ds <- IORef (Map FilePath FilePath)
-> (Map FilePath FilePath
-> (Map FilePath FilePath, Map FilePath FilePath))
-> IO (Map FilePath FilePath)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map FilePath FilePath)
ref ((Map FilePath FilePath
-> (Map FilePath FilePath, Map FilePath FilePath))
-> IO (Map FilePath FilePath))
-> (Map FilePath FilePath
-> (Map FilePath FilePath, Map FilePath FilePath))
-> IO (Map FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ \Map FilePath FilePath
ds -> (Map FilePath FilePath
forall k a. Map k a
Map.empty, Map FilePath FilePath
ds)
Logger -> [FilePath] -> IO ()
removeTmpDirs Logger
logger (Map FilePath FilePath -> [FilePath]
forall k a. Map k a -> [a]
Map.elems Map FilePath FilePath
ds)
cleanTempFiles :: Logger -> TmpFs -> IO ()
cleanTempFiles :: Logger -> TmpFs -> IO ()
cleanTempFiles Logger
logger TmpFs
tmpfs
= IO () -> IO ()
forall a. IO a -> IO a
mask_
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do ([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger) (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpSubdirs Logger
logger) (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
tmpfs)
where
removeWith :: ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith [FilePath] -> IO b
remove IORef PathsToClean
ref = do
[FilePath]
to_delete <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef PathsToClean
ref ((PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath])
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
\PathsToClean
{ ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths
, ptcGhcSession :: PathsToClean -> Set FilePath
ptcGhcSession = Set FilePath
gs_paths
} -> ( PathsToClean
emptyPathsToClean
, Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cm_paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
gs_paths)
[FilePath] -> IO b
remove [FilePath]
to_delete
keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
= IO () -> IO ()
forall a. IO a -> IO a
mask_
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do [FilePath]
to_keep_files <- IORef PathsToClean -> IO [FilePath]
keep (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
[FilePath]
to_keep_subdirs <- IORef PathsToClean -> IO [FilePath]
keep (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
tmpfs)
[FilePath] -> IORef (Map FilePath FilePath) -> IO ()
forall {k}. [FilePath] -> IORef (Map k FilePath) -> IO ()
keepDirs ([FilePath]
to_keep_files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
to_keep_subdirs) (TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean TmpFs
tmpfs)
where
keepDirs :: [FilePath] -> IORef (Map k FilePath) -> IO ()
keepDirs [FilePath]
keeps IORef (Map k FilePath)
ref = do
let keep_dirs :: Set FilePath
keep_dirs = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
takeDirectory [FilePath]
keeps)
IORef (Map k FilePath)
-> (Map k FilePath -> (Map k FilePath, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map k FilePath)
ref ((Map k FilePath -> (Map k FilePath, ())) -> IO ())
-> (Map k FilePath -> (Map k FilePath, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map k FilePath
m -> ((FilePath -> Bool) -> Map k FilePath -> Map k FilePath
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\FilePath
fp -> FilePath
fp FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set FilePath
keep_dirs) Map k FilePath
m, ())
keep :: IORef PathsToClean -> IO [FilePath]
keep IORef PathsToClean
ref = do
[FilePath]
to_keep <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef PathsToClean
ref ((PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath])
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
\ptc :: PathsToClean
ptc@PathsToClean{ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths} ->
(PathsToClean
ptc {ptcCurrentModule = Set.empty}, Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cm_paths)
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Keeping:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text [FilePath]
to_keep))
[FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
to_keep
cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
= IO () -> IO ()
forall a. IO a -> IO a
mask_
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do ([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger) (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpSubdirs Logger
logger) (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
tmpfs)
where
removeWith :: ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith [FilePath] -> IO b
remove IORef PathsToClean
ref = do
[FilePath]
to_delete <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef PathsToClean
ref ((PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath])
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
\ptc :: PathsToClean
ptc@PathsToClean{ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths} ->
(PathsToClean
ptc {ptcCurrentModule = Set.empty}, Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cm_paths)
[FilePath] -> IO b
remove [FilePath]
to_delete
addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
lifetime [FilePath]
new_files =
IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs) TempFileLifetime
lifetime [FilePath]
new_files
addSubdirsToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addSubdirsToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addSubdirsToClean TmpFs
tmpfs TempFileLifetime
lifetime [FilePath]
new_subdirs =
IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
tmpfs) TempFileLifetime
lifetime [FilePath]
new_subdirs
addToClean :: IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean :: IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean IORef PathsToClean
ref TempFileLifetime
lifetime [FilePath]
new_filepaths = IORef PathsToClean -> (PathsToClean -> PathsToClean) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef PathsToClean
ref ((PathsToClean -> PathsToClean) -> IO ())
-> (PathsToClean -> PathsToClean) -> IO ()
forall a b. (a -> b) -> a -> b
$
\PathsToClean
{ ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths
, ptcGhcSession :: PathsToClean -> Set FilePath
ptcGhcSession = Set FilePath
gs_paths
} -> case TempFileLifetime
lifetime of
TempFileLifetime
TFL_CurrentModule -> PathsToClean
{ ptcCurrentModule :: Set FilePath
ptcCurrentModule = Set FilePath
cm_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set FilePath
new_filepaths_set
, ptcGhcSession :: Set FilePath
ptcGhcSession = Set FilePath
gs_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
new_filepaths_set
}
TempFileLifetime
TFL_GhcSession -> PathsToClean
{ ptcCurrentModule :: Set FilePath
ptcCurrentModule = Set FilePath
cm_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
new_filepaths_set
, ptcGhcSession :: Set FilePath
ptcGhcSession = Set FilePath
gs_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set FilePath
new_filepaths_set
}
where
new_filepaths_set :: Set FilePath
new_filepaths_set = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
new_filepaths
changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime TmpFs
tmpfs TempFileLifetime
lifetime [FilePath]
files = do
PathsToClean
{ ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths
, ptcGhcSession :: PathsToClean -> Set FilePath
ptcGhcSession = Set FilePath
gs_paths
} <- IORef PathsToClean -> IO PathsToClean
forall a. IORef a -> IO a
readIORef (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
let old_set :: Set FilePath
old_set = case TempFileLifetime
lifetime of
TempFileLifetime
TFL_CurrentModule -> Set FilePath
gs_paths
TempFileLifetime
TFL_GhcSession -> Set FilePath
cm_paths
existing_files :: [FilePath]
existing_files = [FilePath
f | FilePath
f <- [FilePath]
files, FilePath
f FilePath -> Set FilePath -> Bool
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
newTempSuffix :: TmpFs -> IO Int
newTempSuffix :: TmpFs -> IO Int
newTempSuffix TmpFs
tmpfs =
IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef Int
tmp_next_suffix TmpFs
tmpfs) ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
n -> (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
n)
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_")
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 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
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
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
lifetime [FilePath
filename]
FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filename
newTempSubDir :: Logger -> TmpFs -> TempDir -> IO FilePath
newTempSubDir :: Logger -> TmpFs -> TempDir -> IO FilePath
newTempSubDir 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 name :: FilePath
name = FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n
Bool
b <- FilePath -> IO Bool
doesDirectoryExist FilePath
name
if Bool
b then FilePath -> IO FilePath
findTempDir FilePath
prefix
else (do
FilePath -> IO ()
createDirectory FilePath
name
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addSubdirsToClean TmpFs
tmpfs TempFileLifetime
TFL_GhcSession [FilePath
name]
FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
name)
IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO` \IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
then FilePath -> IO FilePath
findTempDir FilePath
prefix else IOException -> IO FilePath
forall a. IOException -> IO a
ioError IOException
e
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
let libname :: FilePath
libname = FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n
filename :: FilePath
filename = FilePath
dir FilePath -> ShowS
</> FilePath
"lib" FilePath -> ShowS
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
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
lifetime [FilePath
filename]
(FilePath, FilePath, FilePath) -> IO (FilePath, FilePath, FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
filename, FilePath
dir, FilePath
libname)
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 <- IORef (Map FilePath FilePath) -> IO (Map FilePath FilePath)
forall a. IORef a -> IO a
readIORef IORef (Map FilePath FilePath)
dir_ref
case FilePath -> Map FilePath FilePath -> Maybe FilePath
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" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pid FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"_"
IO FilePath -> IO FilePath
forall a. IO a -> IO a
mask_ (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
mkTempDir FilePath
prefix
Just FilePath
dir -> FilePath -> IO FilePath
forall a. a -> IO a
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 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n
FilePath -> IO ()
createDirectory FilePath
our_dir
Maybe FilePath
their_dir <- IORef (Map FilePath FilePath)
-> (Map FilePath FilePath
-> (Map FilePath FilePath, Maybe FilePath))
-> IO (Maybe FilePath)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map FilePath FilePath)
dir_ref ((Map FilePath FilePath -> (Map FilePath FilePath, Maybe FilePath))
-> IO (Maybe FilePath))
-> (Map FilePath FilePath
-> (Map FilePath FilePath, Maybe FilePath))
-> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ \Map FilePath FilePath
mapping ->
case FilePath -> Map FilePath FilePath -> Maybe FilePath
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, FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir)
Maybe FilePath
Nothing -> (FilePath
-> FilePath -> Map FilePath FilePath -> Map FilePath FilePath
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, Maybe FilePath
forall a. Maybe a
Nothing)
case Maybe FilePath
their_dir of
Maybe FilePath
Nothing -> do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Created temporary directory:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
our_dir
FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
our_dir
Just FilePath
dir -> do
FilePath -> IO ()
removeDirectory FilePath
our_dir
FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
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 IOException -> IO FilePath
forall a. IOException -> IO a
ioError IOException
e
removeTmpDirs :: Logger -> [FilePath] -> IO ()
removeTmpDirs :: Logger -> [FilePath] -> IO ()
removeTmpDirs Logger
logger [FilePath]
ds
= Logger -> FilePath -> FilePath -> IO () -> IO ()
forall a. Logger -> FilePath -> FilePath -> IO a -> IO a
traceCmd Logger
logger FilePath
"Deleting temp dirs"
(FilePath
"Deleting: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
ds)
((FilePath -> IO ()) -> [FilePath] -> IO ()
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 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger -> FilePath -> FilePath -> IO () -> IO ()
forall a. Logger -> FilePath -> FilePath -> IO a -> IO a
traceCmd Logger
logger FilePath
"Deleting temp files"
(FilePath
"Deleting: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
deletees)
((FilePath -> IO ()) -> [FilePath] -> IO ()
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
warnNon :: IO () -> IO ()
warnNon IO ()
act
| [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
non_deletees = IO ()
act
| Bool
otherwise = do
Logger -> SDoc -> IO ()
putMsg Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"WARNING - NOT deleting source files:"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text [FilePath]
non_deletees))
IO ()
act
([FilePath]
non_deletees, [FilePath]
deletees) = (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition FilePath -> Bool
isHaskellUserSrcFilename [FilePath]
fs
removeTmpSubdirs :: Logger -> [FilePath] -> IO ()
removeTmpSubdirs :: Logger -> [FilePath] -> IO ()
removeTmpSubdirs Logger
logger [FilePath]
fs
= Logger -> FilePath -> FilePath -> IO () -> IO ()
forall a. Logger -> FilePath -> FilePath -> IO a -> IO a
traceCmd Logger
logger FilePath
"Deleting temp subdirs"
(FilePath
"Deleting: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
fs)
((FilePath -> IO ()) -> [FilePath] -> IO ()
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]
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 IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO`
(\IOException
e ->
let msg :: SDoc
msg = if IOException -> Bool
isDoesNotExistError IOException
e
then FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Warning: deleting non-existent" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
f
else FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Warning: exception raised when deleting"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
f SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (IOException -> FilePath
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)
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO Int
forall a. a -> IO a
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
withSystemTempDirectory :: String
-> (FilePath -> IO a)
-> IO a
withSystemTempDirectory :: forall a. FilePath -> (FilePath -> IO a) -> IO a
withSystemTempDirectory FilePath
template FilePath -> IO a
action =
IO FilePath
getTemporaryDirectory IO FilePath -> (FilePath -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
tmpDir -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory FilePath
tmpDir FilePath
template FilePath -> IO a
action
withTempDirectory :: FilePath
-> String
-> (FilePath -> IO a)
-> IO a
withTempDirectory :: forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory FilePath
targetDir FilePath
template =
IO FilePath -> (FilePath -> IO ()) -> (FilePath -> IO a) -> IO a
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 (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
removeDirectoryRecursive)
ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors IO ()
ioe = IO ()
ioe IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO` IO () -> IOException -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
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 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
x
FilePath -> IO ()
createDirectory FilePath
path
FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
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
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) else IOException -> IO FilePath
forall a. IOException -> IO a
ioError IOException
e