hsc2hs: Make removeFile more reliable on Windows. (#25)
[hsc2hs.git] / Common.hs
1 {-# LANGUAGE CPP #-}
2 module Common where
3
4 import qualified Control.Exception as Exception
5 import Control.Monad ( when )
6 import System.IO
7 #if defined(mingw32_HOST_OS)
8 import Control.Concurrent ( threadDelay )
9 import System.IO.Error ( isPermissionError )
10 #endif
11 import System.Process ( rawSystem, createProcess, waitForProcess
12 , proc, CreateProcess(..), StdStream(..) )
13 import System.Exit ( ExitCode(..), exitWith )
14 import System.Directory ( removeFile )
15
16 die :: String -> IO a
17 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
18
19 default_compiler :: String
20 default_compiler = "gcc"
21
22 ------------------------------------------------------------------------
23 -- Write the output files.
24
25 writeBinaryFile :: FilePath -> String -> IO ()
26 writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
27
28 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
29 rawSystemL action flg prog args = do
30 let cmdLine = prog++" "++unwords args
31 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
32 exitStatus <- rawSystem prog args
33 case exitStatus of
34 ExitFailure exitCode -> die $ action ++ " failed "
35 ++ "(exit code " ++ show exitCode ++ ")\n"
36 ++ "command was: " ++ cmdLine ++ "\n"
37 _ -> return ()
38
39 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
40 rawSystemWithStdOutL action flg prog args outFile = do
41 let cmdLine = prog++" "++unwords args++" >"++outFile
42 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
43 hOut <- openFile outFile WriteMode
44 (_ ,_ ,_ , process) <-
45 -- We use createProcess here instead of runProcess since we need to specify
46 -- a custom CreateProcess structure to turn on use_process_jobs when
47 -- available.
48 createProcess
49 #if MIN_VERSION_process (1,5,0)
50 (proc prog args){ use_process_jobs = True, std_out = UseHandle hOut }
51 #else
52 (proc prog args){ std_out = UseHandle hOut }
53 #endif
54 exitStatus <- waitForProcess process
55 hClose hOut
56 case exitStatus of
57 ExitFailure exitCode -> die $ action ++ " failed "
58 ++ "(exit code " ++ show exitCode ++ ")\n"
59 ++ "command was: " ++ cmdLine ++ "\n"
60 _ -> return ()
61
62 -- delay the cleanup of generated files until the end; attempts to
63 -- get around intermittent failure to delete files which has
64 -- just been exec'ed by a sub-process (Win32 only.)
65 finallyRemove :: FilePath -> IO a -> IO a
66 finallyRemove fp act =
67 Exception.bracket_ (return fp)
68 (noisyRemove fp)
69 act
70 where
71 max_retries :: Int
72 max_retries = 5
73
74 noisyRemove :: FilePath -> IO ()
75 noisyRemove fpath =
76 catchIO (removeFileInternal max_retries fpath)
77 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
78 removeFileInternal _retries path = do
79 #if defined(mingw32_HOST_OS)
80 -- On Windows we have to retry the delete a couple of times.
81 -- The reason for this is that a FileDelete command just marks a
82 -- file for deletion. The file is really only removed when the last
83 -- handle to the file is closed. Unfortunately there are a lot of
84 -- system services that can have a file temporarily opened using a shared
85 -- read-only lock, such as the built in AV and search indexer.
86 --
87 -- We can't really guarantee that these are all off, so what we can do is
88 -- whenever after an rm the file still exists to try again and wait a bit.
89 res <- Exception.try $ removeFile path
90 case res of
91 Right a -> return a
92 Left ex | isPermissionError ex && _retries > 1 -> do
93 let retries' = _retries - 1
94 threadDelay ((max_retries - retries') * 200)
95 removeFileInternal retries' path
96 | otherwise -> Exception.throw ex
97 #else
98 removeFile path
99 #endif
100
101 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
102 catchIO = Exception.catch
103
104 onlyOne :: String -> IO a
105 onlyOne what = die ("Only one "++what++" may be specified\n")