Fix when using g++ as C compiler. Patch from elaforge. Fixes ghc #7232
[hsc2hs.git] / Main.hs
1 {-# OPTIONS -cpp #-}
2 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
3
4 ------------------------------------------------------------------------
5 -- Program for converting .hsc files to .hs files, by converting the
6 -- file into a C program which is run to generate the Haskell source.
7 -- Certain items known only to the C compiler can then be used in
8 -- the Haskell module; for example #defined constants, byte offsets
9 -- within structures, etc.
10 --
11 -- See the documentation in the Users' Guide for more details.
12
13 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
14 #include "../../includes/ghcconfig.h"
15 #endif
16
17 import Control.Monad ( liftM, forM_ )
18 import Data.List ( isSuffixOf )
19 import System.Console.GetOpt
20
21 #if defined(mingw32_HOST_OS)
22 import Foreign
23 import Foreign.C.String
24 #endif
25 import System.Directory ( doesFileExist, findExecutable )
26 import System.Environment ( getProgName, getArgs )
27 import System.Exit ( ExitCode(..), exitWith )
28 import System.IO
29
30 #ifdef BUILD_NHC
31 import System.Directory ( getCurrentDirectory )
32 #else
33 import Data.Version ( showVersion )
34 import Paths_hsc2hs as Main ( getDataFileName, version )
35 #endif
36
37 import Common
38 import CrossCodegen
39 import DirectCodegen
40 import Flags
41 import HSCParser
42
43 #ifdef mingw32_HOST_OS
44 # if defined(i386_HOST_ARCH)
45 # define WINDOWS_CCONV stdcall
46 # elif defined(x86_64_HOST_ARCH)
47 # define WINDOWS_CCONV ccall
48 # else
49 # error Unknown mingw32 arch
50 # endif
51 #endif
52
53 #ifdef BUILD_NHC
54 getDataFileName s = do here <- getCurrentDirectory
55 return (here++"/"++s)
56 version = "0.67" -- TODO!!!
57 showVersion = id
58 #endif
59
60 versionString :: String
61 versionString = "hsc2hs version " ++ showVersion version ++ "\n"
62
63 main :: IO ()
64 main = do
65 prog <- getProgramName
66 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
67 usage = usageInfo header options
68 args <- getArgs
69 let (fs, files, errs) = getOpt Permute options args
70 let mode = foldl (.) id fs emptyMode
71 case mode of
72 Help -> bye usage
73 Version -> bye versionString
74 UseConfig config ->
75 case (files, errs) of
76 ((_:_), []) -> processFiles config files usage
77 (_, _ ) -> die (concat errs ++ usage)
78
79 getProgramName :: IO String
80 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
81 where str `withoutSuffix` suff
82 | suff `isSuffixOf` str = take (length str - length suff) str
83 | otherwise = str
84
85 bye :: String -> IO a
86 bye s = putStr s >> exitWith ExitSuccess
87
88 processFiles :: ConfigM Maybe -> [FilePath] -> String -> IO ()
89 processFiles configM files usage = do
90 mb_libdir <- getLibDir
91
92 (template, extraFlags) <- findTemplate usage mb_libdir configM
93 compiler <- findCompiler mb_libdir configM
94 let linker = case cmLinker configM of
95 Nothing -> compiler
96 Just l -> l
97 config = Config {
98 cmTemplate = Id template,
99 cmCompiler = Id compiler,
100 cmLinker = Id linker,
101 cKeepFiles = cKeepFiles configM,
102 cNoCompile = cNoCompile configM,
103 cCrossCompile = cCrossCompile configM,
104 cCrossSafe = cCrossSafe configM,
105 cVerbose = cVerbose configM,
106 cFlags = cFlags configM ++ extraFlags
107 }
108
109 let outputter = if cCrossCompile config then outputCross else outputDirect
110
111 forM_ files (\name -> do
112 (outName, outDir, outBase) <- case [f | Output f <- cFlags config] of
113 [] -> if not (null ext) && last ext == 'c'
114 then return (dir++base++init ext, dir, base)
115 else
116 if ext == ".hs"
117 then return (dir++base++"_out.hs", dir, base)
118 else return (dir++base++".hs", dir, base)
119 where
120 (dir, file) = splitName name
121 (base, ext) = splitExt file
122 [f] -> let
123 (dir, file) = splitName f
124 (base, _) = splitExt file
125 in return (f, dir, base)
126 _ -> onlyOne "output file"
127 let file_name = dosifyPath name
128 toks <- parseFile file_name
129 outputter config outName outDir outBase file_name toks)
130
131 findTemplate :: String -> Maybe FilePath -> ConfigM Maybe
132 -> IO (FilePath, [Flag])
133 findTemplate usage mb_libdir config
134 = -- If there's no template specified on the commandline, try to locate it
135 case cmTemplate config of
136 Just t ->
137 return (t, [])
138 Nothing -> do
139 -- If there is no Template flag explicitly specified, try
140 -- to find one. We first look near the executable. This only
141 -- works on Win32 or Hugs (getExecDir). If this finds a template
142 -- file then it's certainly the one we want, even if hsc2hs isn't
143 -- installed where we told Cabal it would be installed.
144 --
145 -- Next we try the location we told Cabal about.
146 --
147 -- If neither of the above work, then hopefully we're on Unix and
148 -- there's a wrapper script which specifies an explicit template flag.
149 mb_templ1 <-
150 case mb_libdir of
151 Nothing -> return Nothing
152 Just path -> do
153 -- Euch, this is horrible. Unfortunately
154 -- Paths_hsc2hs isn't too useful for a
155 -- relocatable binary, though.
156 let
157 templ1 = path ++ "/template-hsc.h"
158 incl = path ++ "/include/"
159 exists1 <- doesFileExist templ1
160 if exists1
161 then return $ Just (templ1, CompFlag ("-I" ++ incl))
162 else return Nothing
163 case mb_templ1 of
164 Just (templ1, incl) ->
165 return (templ1, [incl])
166 Nothing -> do
167 templ2 <- getDataFileName "template-hsc.h"
168 exists2 <- doesFileExist templ2
169 if exists2 then return (templ2, [])
170 else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage)
171
172 findCompiler :: Maybe FilePath -> ConfigM Maybe -> IO FilePath
173 findCompiler mb_libdir config
174 = case cmCompiler config of
175 Just c -> return c
176 Nothing ->
177 do let search_path = do
178 mb_path <- findExecutable default_compiler
179 case mb_path of
180 Nothing ->
181 die ("Can't find "++default_compiler++"\n")
182 Just path -> return path
183 -- if this hsc2hs is part of a GHC installation on
184 -- Windows, then we should use the mingw gcc that
185 -- comes with GHC (#3929)
186 inplaceGccs = case mb_libdir of
187 Nothing -> []
188 Just d -> [d ++ "/../mingw/bin/gcc.exe"]
189 search [] = search_path
190 search (x : xs) = do b <- doesFileExist x
191 if b then return x else search xs
192 search inplaceGccs
193
194 parseFile :: String -> IO [Token]
195 parseFile name
196 = do h <- openBinaryFile name ReadMode
197 -- use binary mode so we pass through UTF-8, see GHC ticket #3837
198 -- But then on Windows we end up turning things like
199 -- #let alignment t = e^M
200 -- into
201 -- #define hsc_alignment(t ) printf ( e^M);
202 -- which gcc doesn't like, so strip out any ^M characters.
203 s <- hGetContents h
204 let s' = filter ('\r' /=) s
205 case runParser parser name s' of
206 Success _ _ _ toks -> return toks
207 Failure (SourcePos name' line) msg ->
208 die (name'++":"++show line++": "++msg++"\n")
209
210 getLibDir :: IO (Maybe String)
211 getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
212
213 -- (getExecDir cmd) returns the directory in which the current
214 -- executable, which should be called 'cmd', is running
215 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
216 -- you'll get "/a/b/c" back as the result
217 getExecDir :: String -> IO (Maybe String)
218 getExecDir cmd =
219 getExecPath >>= maybe (return Nothing) removeCmdSuffix
220 where initN n = reverse . drop n . reverse
221 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
222
223 getExecPath :: IO (Maybe String)
224 #if defined(mingw32_HOST_OS)
225 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
226 where
227 try_size size = allocaArray (fromIntegral size) $ \buf -> do
228 ret <- c_GetModuleFileName nullPtr buf size
229 case ret of
230 0 -> return Nothing
231 _ | ret < size -> fmap Just $ peekCWString buf
232 | otherwise -> try_size (size * 2)
233
234 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
235 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
236 #else
237 getExecPath = return Nothing
238 #endif