{-# 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
data TempFileLifetime
= TFL_CurrentModule
| TFL_GhcSession
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 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
$ \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)
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles 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
cleanCurrentModuleTempFiles :: DynFlags -> IO ()
cleanCurrentModuleTempFiles :: DynFlags -> IO ()
cleanCurrentModuleTempFiles 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
addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean :: DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
lifetime [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
TempFileLifetime
TFL_CurrentModule -> FilesToClean :: 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
}
TempFileLifetime
TFL_GhcSession -> FilesToClean :: 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
changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [String] -> IO ()
changeTempFilesLifetime DynFlags
dflags TempFileLifetime
lifetime [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
TempFileLifetime
TFL_CurrentModule -> Set String
gs_files
TempFileLifetime
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
newTempSuffix :: DynFlags -> IO Int
newTempSuffix :: DynFlags -> IO Int
newTempSuffix 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
$ \Int
n -> (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
n)
newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath
newTempName :: DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
lifetime String
extn
= do String
d <- DynFlags -> IO String
getTempDir DynFlags
dflags
String -> IO String
findTempName (String
d String -> ShowS
</> String
"ghc_")
where
findTempName :: FilePath -> IO FilePath
findTempName :: String -> IO String
findTempName 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
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 DynFlags
dflags
= do String
d <- DynFlags -> IO String
getTempDir DynFlags
dflags
String -> IO String
findTempDir (String
d String -> ShowS
</> String
"ghc_")
where
findTempDir :: FilePath -> IO FilePath
findTempDir :: String -> IO String
findTempDir 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
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 DynFlags
dflags TempFileLifetime
lifetime String
extn
= do String
d <- DynFlags -> IO String
getTempDir DynFlags
dflags
String -> String -> IO (String, String, String)
findTempName String
d (String
"ghc_")
where
findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
findTempName :: String -> String -> IO (String, String, String)
findTempName String
dir String
prefix
= do Int
n <- DynFlags -> IO Int
newTempSuffix DynFlags
dflags
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
</> String
"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
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)
getTempDir :: DynFlags -> IO FilePath
getTempDir :: DynFlags -> IO String
getTempDir 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
Maybe String
Nothing -> do
Int
pid <- IO Int
getProcessID
let prefix :: String
prefix = String
tmp_dir String -> ShowS
</> String
"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]
++ String
"_"
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 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 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
String -> IO ()
createDirectory String
our_dir
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
$ \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 String
dir -> (Map String String
mapping, String -> Maybe String
forall a. a -> Maybe a
Just String
dir)
Maybe String
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)
case Maybe String
their_dir of
Maybe String
Nothing -> do
DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> MsgDoc
text String
"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 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` \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
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs :: DynFlags -> [String] -> IO ()
removeTmpDirs DynFlags
dflags [String]
ds
= DynFlags -> String -> String -> IO () -> IO ()
forall a. DynFlags -> String -> String -> IO a -> IO a
traceCmd DynFlags
dflags String
"Deleting temp dirs"
(String
"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 DynFlags
dflags [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 String
"Deleting temp files"
(String
"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
warnNon :: IO b -> IO b
warnNon 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 String
"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
([String]
non_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 DynFlags
dflags String -> IO ()
remover String
f = String -> IO ()
remover String
f IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO`
(\IOException
e ->
let msg :: MsgDoc
msg = if IOException -> Bool
isDoesNotExistError IOException
e
then String -> MsgDoc
text String
"Warning: deleting non-existent" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
f
else String -> MsgDoc
text String
"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 Int
2 MsgDoc
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 (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
withSystemTempDirectory :: String
-> (FilePath -> IO a)
-> IO a
withSystemTempDirectory :: String -> (String -> IO a) -> IO a
withSystemTempDirectory String
template 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
>>= \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
withTempDirectory :: FilePath
-> String
-> (FilePath -> IO a)
-> IO a
withTempDirectory :: String -> String -> (String -> IO a) -> IO a
withTempDirectory String
targetDir 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 IO ()
ioe = IO ()
ioe IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\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 String
dir 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 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` \IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
then a -> IO String
findTempName (a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
1) else IOException -> IO String
forall a. IOException -> IO a
ioError IOException
e