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