Follow changes in GHC build system
[hsc2hs.git] / Common.hs
1 {-# LANGUAGE CPP #-}
2 module Common where
3
4 import Control.Exception ( bracket_ )
5 import qualified Control.Exception as Exception
6 import Control.Monad ( when )
7 import System.IO
8
9 import System.Process ( rawSystem, runProcess, waitForProcess )
10
11 import System.Exit ( ExitCode(..), exitWith )
12 import System.Directory ( removeFile )
13
14 die :: String -> IO a
15 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
16
17 default_compiler :: String
18 default_compiler = "gcc"
19
20 ------------------------------------------------------------------------
21 -- Write the output files.
22
23 writeBinaryFile :: FilePath -> String -> IO ()
24 writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
25
26 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
27 rawSystemL action flg prog args = do
28 let cmdLine = prog++" "++unwords args
29 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
30 exitStatus <- rawSystem prog args
31 case exitStatus of
32 ExitFailure exitCode -> die $ action ++ " failed "
33 ++ "(exit code " ++ show exitCode ++ ")\n"
34 ++ "command was: " ++ cmdLine ++ "\n"
35 _ -> return ()
36
37 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
38 rawSystemWithStdOutL action flg prog args outFile = do
39 let cmdLine = prog++" "++unwords args++" >"++outFile
40 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
41 hOut <- openFile outFile WriteMode
42 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
43 exitStatus <- waitForProcess process
44 hClose hOut
45 case exitStatus of
46 ExitFailure exitCode -> die $ action ++ " failed "
47 ++ "(exit code " ++ show exitCode ++ ")\n"
48 ++ "command was: " ++ cmdLine ++ "\n"
49 _ -> return ()
50
51 -- delay the cleanup of generated files until the end; attempts to
52 -- get around intermittent failure to delete files which has
53 -- just been exec'ed by a sub-process (Win32 only.)
54 finallyRemove :: FilePath -> IO a -> IO a
55 finallyRemove fp act =
56 bracket_ (return fp)
57 (noisyRemove fp)
58 act
59 where
60 noisyRemove fpath =
61 catchIO (removeFile fpath)
62 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
63
64 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
65 catchIO = Exception.catch
66
67 onlyOne :: String -> IO a
68 onlyOne what = die ("Only one "++what++" may be specified\n")
69