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