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