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 (Show)
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
= unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = dirsToClean dflags
ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
removeTmpDirs dflags (Map.elems ds)
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
= unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = filesToClean dflags
to_delete <- atomicModifyIORef' ref $
\FilesToClean
{ ftcCurrentModule = cm_files
, ftcGhcSession = gs_files
} -> ( emptyFilesToClean
, Set.toList cm_files ++ Set.toList gs_files)
removeTmpFiles dflags to_delete
cleanCurrentModuleTempFiles :: DynFlags -> IO ()
cleanCurrentModuleTempFiles dflags
= unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = filesToClean dflags
to_delete <- atomicModifyIORef' ref $
\ftc@FilesToClean{ftcCurrentModule = cm_files} ->
(ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)
removeTmpFiles dflags to_delete
addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $
\FilesToClean
{ ftcCurrentModule = cm_files
, ftcGhcSession = gs_files
} -> case lifetime of
TFL_CurrentModule -> FilesToClean
{ ftcCurrentModule = cm_files `Set.union` new_files_set
, ftcGhcSession = gs_files `Set.difference` new_files_set
}
TFL_GhcSession -> FilesToClean
{ ftcCurrentModule = cm_files `Set.difference` new_files_set
, ftcGhcSession = gs_files `Set.union` new_files_set
}
where
new_files_set = Set.fromList new_files
changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime dflags lifetime files = do
FilesToClean
{ ftcCurrentModule = cm_files
, ftcGhcSession = gs_files
} <- readIORef (filesToClean dflags)
let old_set = case lifetime of
TFL_CurrentModule -> gs_files
TFL_GhcSession -> cm_files
existing_files = [f | f <- files, f `Set.member` old_set]
addFilesToClean dflags lifetime existing_files
newTempSuffix :: DynFlags -> IO Int
newTempSuffix dflags =
atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath
newTempName dflags lifetime extn
= do d <- getTempDir dflags
findTempName (d </> "ghc_")
where
findTempName :: FilePath -> IO FilePath
findTempName prefix
= do n <- newTempSuffix dflags
let filename = prefix ++ show n <.> extn
b <- doesFileExist filename
if b then findTempName prefix
else do
addFilesToClean dflags lifetime [filename]
return filename
newTempDir :: DynFlags -> IO FilePath
newTempDir dflags
= do d <- getTempDir dflags
findTempDir (d </> "ghc_")
where
findTempDir :: FilePath -> IO FilePath
findTempDir prefix
= do n <- newTempSuffix dflags
let filename = prefix ++ show n
b <- doesDirectoryExist filename
if b then findTempDir prefix
else do createDirectory filename
return filename
newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
-> IO (FilePath, FilePath, String)
newTempLibName dflags lifetime extn
= do d <- getTempDir dflags
findTempName d ("ghc_")
where
findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
findTempName dir prefix
= do n <- newTempSuffix dflags
let libname = prefix ++ show n
filename = dir </> "lib" ++ libname <.> extn
b <- doesFileExist filename
if b then findTempName dir prefix
else do
addFilesToClean dflags lifetime [filename]
return (filename, dir, libname)
getTempDir :: DynFlags -> IO FilePath
getTempDir dflags = do
mapping <- readIORef dir_ref
case Map.lookup tmp_dir mapping of
Nothing -> do
pid <- getProcessID
let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
mask_ $ mkTempDir prefix
Just dir -> return dir
where
tmp_dir = tmpDir dflags
dir_ref = dirsToClean dflags
mkTempDir :: FilePath -> IO FilePath
mkTempDir prefix = do
n <- newTempSuffix dflags
let our_dir = prefix ++ show n
createDirectory our_dir
their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
case Map.lookup tmp_dir mapping of
Just dir -> (mapping, Just dir)
Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
case their_dir of
Nothing -> do
debugTraceMsg dflags 2 $
text "Created temporary directory:" <+> text our_dir
return our_dir
Just dir -> do
removeDirectory our_dir
return dir
`catchIO` \e -> if isAlreadyExistsError e
then mkTempDir prefix else ioError e
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
= traceCmd dflags "Deleting temp dirs"
("Deleting: " ++ unwords ds)
(mapM_ (removeWith dflags removeDirectory) ds)
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
= warnNon $
traceCmd dflags "Deleting temp files"
("Deleting: " ++ unwords deletees)
(mapM_ (removeWith dflags removeFile) deletees)
where
warnNon act
| null non_deletees = act
| otherwise = do
putMsg dflags (text "WARNING - NOT deleting source files:"
<+> hsep (map text non_deletees))
act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith dflags remover f = remover f `catchIO`
(\e ->
let msg = if isDoesNotExistError e
then text "Warning: deleting non-existent" <+> text f
else text "Warning: exception raised when deleting"
<+> text f <> colon
$$ text (show e)
in debugTraceMsg dflags 2 msg
)
#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "_getpid" getProcessID :: IO Int
#else
getProcessID :: IO Int
getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#endif
withSystemTempDirectory :: String
-> (FilePath -> IO a)
-> IO a
withSystemTempDirectory template action =
getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action
withTempDirectory :: FilePath
-> String
-> (FilePath -> IO a)
-> IO a
withTempDirectory targetDir template =
Exception.bracket
(createTempDirectory targetDir template)
(ignoringIOErrors . removeDirectoryRecursive)
ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError))
createTempDirectory :: FilePath -> String -> IO FilePath
createTempDirectory dir template = do
pid <- getProcessID
findTempName pid
where findTempName x = do
let path = dir </> template ++ show x
createDirectory path
return path
`catchIO` \e -> if isAlreadyExistsError e
then findTempName (x+1) else ioError e