diff options
Diffstat (limited to 'compiler/main/FileCleanup.hs')
| -rw-r--r-- | compiler/main/FileCleanup.hs | 67 |
1 files changed, 66 insertions, 1 deletions
diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs index f4c30d6112..35bed6149b 100644 --- a/compiler/main/FileCleanup.hs +++ b/compiler/main/FileCleanup.hs @@ -3,9 +3,12 @@ module FileCleanup ( TempFileLifetime(..) , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles , addFilesToClean, changeTempFilesLifetime - , newTempName, newTempLibName + , newTempName, newTempLibName, newTempDir + , withSystemTempDirectory, withTempDirectory ) where +import GhcPrelude + import DynFlags import ErrUtils import Outputable @@ -129,6 +132,21 @@ newTempName dflags lifetime extn 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 + -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename + return filename + newTempLibName :: DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) newTempLibName dflags lifetime extn @@ -247,3 +265,50 @@ foreign import ccall unsafe "_getpid" getProcessID :: IO Int getProcessID :: IO Int getProcessID = System.Posix.Internals.c_getpid >>= return . 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 template action = + getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template 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 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 |