Remove the support for old GHC versions
[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 ( runProcess, waitForProcess )
10
11 import System.Cmd ( rawSystem )
12
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 splitName :: String -> (String, String)
26 splitName name =
27 case break (== '/') name of
28 (file, []) -> ([], file)
29 (dir, sep:rest) -> (dir++sep:restDir, restFile)
30 where
31 (restDir, restFile) = splitName rest
32
33 splitExt :: String -> (String, String)
34 splitExt name =
35 case break (== '.') name of
36 (base, []) -> (base, [])
37 (base, sepRest@(sep:rest))
38 | null restExt -> (base, sepRest)
39 | otherwise -> (base++sep:restBase, restExt)
40 where
41 (restBase, restExt) = splitExt rest
42
43 writeBinaryFile :: FilePath -> String -> IO ()
44 writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
45
46 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
47 rawSystemL action flg prog args = do
48 let cmdLine = prog++" "++unwords args
49 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
50 exitStatus <- rawSystem prog args
51 case exitStatus of
52 ExitFailure exitCode -> die $ action ++ " failed "
53 ++ "(exit code " ++ show exitCode ++ ")\n"
54 ++ "command was: " ++ cmdLine ++ "\n"
55 _ -> return ()
56
57 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
58 rawSystemWithStdOutL action flg prog args outFile = do
59 let cmdLine = prog++" "++unwords args++" >"++outFile
60 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
61 hOut <- openFile outFile WriteMode
62 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
63 exitStatus <- waitForProcess process
64 hClose hOut
65 case exitStatus of
66 ExitFailure exitCode -> die $ action ++ " failed "
67 ++ "(exit code " ++ show exitCode ++ ")\n"
68 ++ "command was: " ++ cmdLine ++ "\n"
69 _ -> return ()
70
71 -- delay the cleanup of generated files until the end; attempts to
72 -- get around intermittent failure to delete files which has
73 -- just been exec'ed by a sub-process (Win32 only.)
74 finallyRemove :: FilePath -> IO a -> IO a
75 finallyRemove fp act =
76 bracket_ (return fp)
77 (noisyRemove fp)
78 act
79 where
80 noisyRemove fpath =
81 catchIO (removeFile fpath)
82 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
83
84 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
85 catchIO = Exception.catch
86
87 onlyOne :: String -> IO a
88 onlyOne what = die ("Only one "++what++" may be specified\n")
89
90 -----------------------------------------
91 -- Modified version from ghc/compiler/SysTools
92 -- Convert paths foo/baz to foo\baz on Windows
93
94 subst :: Char -> Char -> String -> String
95 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
96 subst a b = map (\x -> if x == a then b else x)
97 #else
98 subst _ _ = id
99 #endif
100
101 dosifyPath :: String -> String
102 dosifyPath = subst '/' '\\'
103
104 unDosifyPath :: String -> String
105 unDosifyPath = subst '\\' '/'
106