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