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