Fix enum cross-compilation support
[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 HSCParser
41
42 #ifdef BUILD_NHC
43 getDataFileName s = do here <- getCurrentDirectory
44 return (here++"/"++s)
45 version = "0.67" -- TODO!!!
46 showVersion = id
47 #endif
48
49 versionString :: String
50 versionString = "hsc2hs version " ++ showVersion version ++ "\n"
51
52 template_flag :: Flag -> Bool
53 template_flag (Template _) = True
54 template_flag _ = False
55
56 include :: String -> Flag
57 include s@('\"':_) = Include s
58 include s@('<' :_) = Include s
59 include s = Include ("\""++s++"\"")
60
61 define :: String -> Flag
62 define s = case break (== '=') s of
63 (name, []) -> Define name Nothing
64 (name, _:value) -> Define name (Just value)
65
66 options :: [OptDescr Flag]
67 options = [
68 Option ['o'] ["output"] (ReqArg Output "FILE")
69 "name of main output file",
70 Option ['t'] ["template"] (ReqArg Template "FILE")
71 "template file",
72 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
73 "C compiler to use",
74 Option ['l'] ["ld"] (ReqArg Linker "PROG")
75 "linker to use",
76 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
77 "flag to pass to the C compiler",
78 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
79 "passed to the C compiler",
80 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
81 "flag to pass to the linker",
82 Option ['i'] ["include"] (ReqArg include "FILE")
83 "as if placed in the source",
84 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
85 "as if placed in the source",
86 Option [] ["no-compile"] (NoArg NoCompile)
87 "stop after writing *_hsc_make.c",
88 Option ['x'] ["cross-compile"] (NoArg CrossCompile)
89 "activate cross-compilation mode",
90 Option [] ["cross-safe"] (NoArg CrossSafe)
91 "restrict .hsc directives to those supported by --cross-compile",
92 Option ['k'] ["keep-files"] (NoArg KeepFiles)
93 "do not remove temporary files",
94 Option ['v'] ["verbose"] (NoArg Verbose)
95 "dump commands to stderr",
96 Option ['?'] ["help"] (NoArg Help)
97 "display this help and exit",
98 Option ['V'] ["version"] (NoArg Version)
99 "output version information and exit" ]
100
101 main :: IO ()
102 main = do
103 prog <- getProgramName
104 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
105 usage = usageInfo header options
106 args <- getArgs
107 let (flags, files, errs) = getOpt Permute options args
108 case (files, errs) of
109 (_, _)
110 | any isHelp flags -> bye usage
111 | any isVersion flags -> bye versionString
112 where
113 isHelp Help = True; isHelp _ = False
114 isVersion Version = True; isVersion _ = False
115 ((_:_), []) -> processFiles flags files usage
116 (_, _ ) -> die (concat errs ++ usage)
117
118 getProgramName :: IO String
119 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
120 where str `withoutSuffix` suff
121 | suff `isSuffixOf` str = take (length str - length suff) str
122 | otherwise = str
123
124 bye :: String -> IO a
125 bye s = putStr s >> exitWith ExitSuccess
126
127 processFiles :: [Flag] -> [FilePath] -> String -> IO ()
128 processFiles flags files usage = do
129 mb_libdir <- getLibDir
130
131 -- If there's no template specified on the commandline, try to locate it
132 flags_w_tpl <- case filter template_flag flags of
133 [_] -> return flags
134 (_:_) -> -- take only the last --template flag on the cmd line
135 let (before,tpl:after) = break template_flag (reverse flags)
136 in return $ reverse (before ++ tpl : filter (not.template_flag) after)
137 [] -> do -- If there is no Template flag explicitly specified, try
138 -- to find one. We first look near the executable. This only
139 -- works on Win32 or Hugs (getExecDir). If this finds a template
140 -- file then it's certainly the one we want, even if hsc2hs isn't
141 -- installed where we told Cabal it would be installed.
142 --
143 -- Next we try the location we told Cabal about.
144 --
145 -- If neither of the above work, then hopefully we're on Unix and
146 -- there's a wrapper script which specifies an explicit template flag.
147 mb_templ1 <-
148 case mb_libdir of
149 Nothing -> return Nothing
150 Just path -> do
151 -- Euch, this is horrible. Unfortunately
152 -- Paths_hsc2hs isn't too useful for a
153 -- relocatable binary, though.
154 let
155 #if defined(NEW_GHC_LAYOUT)
156 templ1 = path ++ "/template-hsc.h"
157 #else
158 templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h"
159 #endif
160 incl = path ++ "/include/"
161 exists1 <- doesFileExist templ1
162 if exists1
163 then return $ Just (Template templ1,
164 CompFlag ("-I" ++ incl))
165 else return Nothing
166 case mb_templ1 of
167 Just (templ1, incl) -> return (templ1 : flags ++ [incl])
168 Nothing -> do
169 templ2 <- getDataFileName "template-hsc.h"
170 exists2 <- doesFileExist templ2
171 if exists2 then return (Template templ2 : flags)
172 else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage)
173
174 compiler <- case [c | Compiler c <- flags_w_tpl] of
175 [] -> do
176 -- if this hsc2hs is part of a GHC installation on
177 -- Windows, then we should use the mingw gcc that
178 -- comes with GHC (#3929)
179 case mb_libdir of
180 Nothing -> search_path
181 Just d -> do
182 let inplace_gcc = d ++ "/../mingw/bin/gcc.exe"
183 b <- doesFileExist inplace_gcc
184 if b then return inplace_gcc else search_path
185 where
186 search_path = do
187 mb_path <- findExecutable default_compiler
188 case mb_path of
189 Nothing -> die ("Can't find "++default_compiler++"\n")
190 Just path -> return path
191 cs -> return (last cs)
192
193 let crossCompiling = not $ null [() | CrossCompile <- flags_w_tpl]
194 beVerbose = not $ null [() | Verbose <- flags_w_tpl]
195 keepFiles = not $ null [() | KeepFiles <- flags_w_tpl]
196
197 outputter <- if crossCompiling
198 then return (outputCross beVerbose keepFiles compiler flags_w_tpl)
199 else do linker <- case [l | Linker l <- flags_w_tpl] of
200 [] -> return compiler
201 ls -> return (last ls)
202 return (outputDirect flags_w_tpl beVerbose keepFiles compiler linker)
203
204 forM_ files (\name -> do
205 (outName, outDir, outBase) <- case [f | Output f <- flags_w_tpl] of
206 [] -> if not (null ext) && last ext == 'c'
207 then return (dir++base++init ext, dir, base)
208 else
209 if ext == ".hs"
210 then return (dir++base++"_out.hs", dir, base)
211 else return (dir++base++".hs", dir, base)
212 where
213 (dir, file) = splitName name
214 (base, ext) = splitExt file
215 [f] -> let
216 (dir, file) = splitName f
217 (base, _) = splitExt file
218 in return (f, dir, base)
219 _ -> onlyOne "output file"
220 let file_name = dosifyPath name
221 toks <- parseFile file_name
222 outputter outName outDir outBase file_name toks)
223
224 parseFile :: String -> IO [Token]
225 parseFile name
226 = do h <- openBinaryFile name ReadMode
227 -- use binary mode so we pass through UTF-8, see GHC ticket #3837
228 -- But then on Windows we end up turning things like
229 -- #let alignment t = e^M
230 -- into
231 -- #define hsc_alignment(t ) printf ( e^M);
232 -- which gcc doesn't like, so strip out any ^M characters.
233 s <- hGetContents h
234 let s' = filter ('\r' /=) s
235 case runParser parser name s' of
236 Success _ _ _ toks -> return toks
237 Failure (SourcePos name' line) msg ->
238 die (name'++":"++show line++": "++msg++"\n")
239
240 getLibDir :: IO (Maybe String)
241 #if defined(NEW_GHC_LAYOUT)
242 getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
243 #else
244 getLibDir = getExecDir "/bin/hsc2hs.exe"
245 #endif
246
247 -- (getExecDir cmd) returns the directory in which the current
248 -- executable, which should be called 'cmd', is running
249 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
250 -- you'll get "/a/b/c" back as the result
251 getExecDir :: String -> IO (Maybe String)
252 getExecDir cmd =
253 getExecPath >>= maybe (return Nothing) removeCmdSuffix
254 where initN n = reverse . drop n . reverse
255 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
256
257 getExecPath :: IO (Maybe String)
258 #if defined(mingw32_HOST_OS)
259 getExecPath =
260 allocaArray len $ \buf -> do
261 ret <- getModuleFileName nullPtr buf len
262 if ret == 0 then return Nothing
263 else liftM Just $ peekCString buf
264 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
265
266 foreign import stdcall unsafe "GetModuleFileNameA"
267 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
268 #else
269 getExecPath = return Nothing
270 #endif