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