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