[project @ 2001-06-13 15:50:25 by rrt]
[ghc-hetmet.git] / ghc / compiler / main / TmpFiles.hs
1 -----------------------------------------------------------------------------
2 -- $Id: TmpFiles.hs,v 1.22 2001/06/13 15:50:25 rrt Exp $
3 --
4 -- Temporary file management
5 --
6 -- (c) The University of Glasgow 2000
7 --
8 -----------------------------------------------------------------------------
9
10 module TmpFiles (
11    Suffix,
12    initTempFileStorage,  -- :: IO ()
13    cleanTempFiles,       -- :: Int -> IO ()
14    cleanTempFilesExcept, -- :: Int -> [FilePath] -> IO ()
15    newTempName,          -- :: Suffix -> IO FilePath
16    addFilesToClean,      -- :: [FilePath] -> IO ()
17    removeTmpFiles,       -- :: Int -> [FilePath] -> IO ()
18    v_TmpDir
19  ) where
20
21 -- main
22 import DriverUtil
23 import Config
24 import Panic
25 import Util
26
27 -- hslibs
28 import Exception
29 import IOExts
30
31 -- std
32 import System
33 import Directory
34 import IO
35 import Monad
36
37 #include "../includes/config.h"
38 #include "HsVersions.h"
39
40 GLOBAL_VAR(v_FilesToClean, [],               [String] )
41 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
42
43
44 initTempFileStorage = do
45         -- check whether TMPDIR is set in the environment
46    IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
47 #ifndef mingw32_TARGET_OS
48               writeIORef v_TmpDir dir
49 #endif
50               return ()
51           )
52
53 cleanTempFiles :: Int -> IO ()
54 cleanTempFiles verb = do
55   fs <- readIORef v_FilesToClean
56   removeTmpFiles verb fs
57
58 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
59 cleanTempFilesExcept verb dont_delete = do
60   fs <- readIORef v_FilesToClean
61   let leftovers = filter (`notElem` dont_delete) fs
62   removeTmpFiles verb leftovers
63   writeIORef v_FilesToClean dont_delete
64
65 type Suffix = String
66
67 -- find a temporary name that doesn't already exist.
68 newTempName :: Suffix -> IO FilePath
69 newTempName extn = do
70   x <- myGetProcessID
71   tmp_dir <- readIORef v_TmpDir
72   findTempName tmp_dir x
73   where findTempName tmp_dir x = do
74            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
75            b  <- doesFileExist filename
76            if b then findTempName tmp_dir (x+1)
77                 else do add v_FilesToClean filename -- clean it up later
78                         return filename
79
80 addFilesToClean :: [FilePath] -> IO ()
81 addFilesToClean files = mapM_ (add v_FilesToClean) files
82
83 removeTmpFiles :: Int -> [FilePath] -> IO ()
84 removeTmpFiles verb fs = do
85   let verbose = verb >= 2
86       blowAway f =
87            (do  when verbose (hPutStrLn stderr ("Removing: " ++ f))
88                 if '*' `elem` f 
89 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
90                   then system (unwords [cRM, dosifyPath f]) >> return ()
91 #else
92                   then system (unwords [cRM, f]) >> return ()
93 #endif
94                   else removeFile f)
95             `catchAllIO`
96            (\_ -> when verbose (hPutStrLn stderr 
97                                 ("Warning: can't remove tmp file " ++ f)))
98   mapM_ blowAway fs