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