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