d3b28931eb525bd6770f9372bb65b9378e0f486b
[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 )
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.IO
29
30 #ifdef BUILD_NHC
31 import System.Directory ( getCurrentDirectory )
32 #else
33 import Data.Version ( showVersion )
34 import Paths_hsc2hs as Main ( getDataFileName, version )
35 #endif
36
37 import HSCParser
38 import DirectCodegen
39
40 #ifdef BUILD_NHC
41 getDataFileName s = do here <- getCurrentDirectory
42 return (here++"/"++s)
43 version = "0.67" -- TODO!!!
44 showVersion = id
45 #endif
46
47 versionString :: String
48 versionString = "hsc2hs version " ++ showVersion version ++ "\n"
49
50 template_flag :: Flag -> Bool
51 template_flag (Template _) = True
52 template_flag _ = False
53
54 include :: String -> Flag
55 include s@('\"':_) = Include s
56 include s@('<' :_) = Include s
57 include s = Include ("\""++s++"\"")
58
59 define :: String -> Flag
60 define s = case break (== '=') s of
61 (name, []) -> Define name Nothing
62 (name, _:value) -> Define name (Just value)
63
64 options :: [OptDescr Flag]
65 options = [
66 Option ['o'] ["output"] (ReqArg Output "FILE")
67 "name of main output file",
68 Option ['t'] ["template"] (ReqArg Template "FILE")
69 "template file",
70 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
71 "C compiler to use",
72 Option ['l'] ["ld"] (ReqArg Linker "PROG")
73 "linker to use",
74 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
75 "flag to pass to the C compiler",
76 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
77 "passed to the C compiler",
78 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
79 "flag to pass to the linker",
80 Option ['i'] ["include"] (ReqArg include "FILE")
81 "as if placed in the source",
82 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
83 "as if placed in the source",
84 Option [] ["no-compile"] (NoArg NoCompile)
85 "stop after writing *_hsc_make.c",
86 Option ['k'] ["keep-files"] (NoArg KeepFiles)
87 "do not remove temporary files",
88 Option ['v'] ["verbose"] (NoArg Verbose)
89 "dump commands to stderr",
90 Option ['?'] ["help"] (NoArg Help)
91 "display this help and exit",
92 Option ['V'] ["version"] (NoArg Version)
93 "output version information and exit" ]
94
95 main :: IO ()
96 main = do
97 prog <- getProgramName
98 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
99 usage = usageInfo header options
100 args <- getArgs
101 let (flags, files, errs) = getOpt Permute options args
102 case (files, errs) of
103 (_, _)
104 | any isHelp flags -> bye usage
105 | any isVersion flags -> bye versionString
106 where
107 isHelp Help = True; isHelp _ = False
108 isVersion Version = True; isVersion _ = False
109 ((_:_), []) -> processFiles flags files usage
110 (_, _ ) -> die (concat errs ++ usage)
111
112 getProgramName :: IO String
113 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
114 where str `withoutSuffix` suff
115 | suff `isSuffixOf` str = take (length str - length suff) str
116 | otherwise = str
117
118 bye :: String -> IO a
119 bye s = putStr s >> exitWith ExitSuccess
120
121 processFiles :: [Flag] -> [FilePath] -> String -> IO ()
122 processFiles flags files usage = do
123 mb_libdir <- getLibDir
124
125 -- If there's no template specified on the commandline, try to locate it
126 flags_w_tpl <- case filter template_flag flags of
127 [_] -> return flags
128 (_:_) -> -- take only the last --template flag on the cmd line
129 let (before,tpl:after) = break template_flag (reverse flags)
130 in return $ reverse (before ++ tpl : filter (not.template_flag) after)
131 [] -> do -- If there is no Template flag explicitly specified, try
132 -- to find one. We first look near the executable. This only
133 -- works on Win32 or Hugs (getExecDir). If this finds a template
134 -- file then it's certainly the one we want, even if hsc2hs isn't
135 -- installed where we told Cabal it would be installed.
136 --
137 -- Next we try the location we told Cabal about.
138 --
139 -- If neither of the above work, then hopefully we're on Unix and
140 -- there's a wrapper script which specifies an explicit template flag.
141 mb_templ1 <-
142 case mb_libdir of
143 Nothing -> return Nothing
144 Just path -> do
145 -- Euch, this is horrible. Unfortunately
146 -- Paths_hsc2hs isn't too useful for a
147 -- relocatable binary, though.
148 let
149 #if defined(NEW_GHC_LAYOUT)
150 templ1 = path ++ "/template-hsc.h"
151 #else
152 templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h"
153 #endif
154 incl = path ++ "/include/"
155 exists1 <- doesFileExist templ1
156 if exists1
157 then return $ Just (Template templ1,
158 CompFlag ("-I" ++ incl))
159 else return Nothing
160 case mb_templ1 of
161 Just (templ1, incl) -> return (templ1 : flags ++ [incl])
162 Nothing -> do
163 templ2 <- getDataFileName "template-hsc.h"
164 exists2 <- doesFileExist templ2
165 if exists2 then return (Template templ2 : flags)
166 else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage)
167
168 compiler <- case [c | Compiler c <- flags_w_tpl] of
169 [] -> do
170 -- if this hsc2hs is part of a GHC installation on
171 -- Windows, then we should use the mingw gcc that
172 -- comes with GHC (#3929)
173 case mb_libdir of
174 Nothing -> search_path
175 Just d -> do
176 let inplace_gcc = d ++ "/../mingw/bin/gcc.exe"
177 b <- doesFileExist inplace_gcc
178 if b then return inplace_gcc else search_path
179 where
180 search_path = do
181 mb_path <- findExecutable default_compiler
182 case mb_path of
183 Nothing -> die ("Can't find "++default_compiler++"\n")
184 Just path -> return path
185 cs -> return (last cs)
186
187 mapM_ (processFile flags_w_tpl compiler) files
188
189 processFile :: [Flag] -> FilePath -> String -> IO ()
190 processFile flags compiler name
191 = do let file_name = dosifyPath name
192 toks <- parseFile file_name
193 output flags compiler file_name toks
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 #if defined(NEW_GHC_LAYOUT)
213 getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
214 #else
215 getLibDir = getExecDir "/bin/hsc2hs.exe"
216 #endif
217
218 -- (getExecDir cmd) returns the directory in which the current
219 -- executable, which should be called 'cmd', is running
220 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
221 -- you'll get "/a/b/c" back as the result
222 getExecDir :: String -> IO (Maybe String)
223 getExecDir cmd =
224 getExecPath >>= maybe (return Nothing) removeCmdSuffix
225 where initN n = reverse . drop n . reverse
226 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
227
228 getExecPath :: IO (Maybe String)
229 #if defined(mingw32_HOST_OS)
230 getExecPath =
231 allocaArray len $ \buf -> do
232 ret <- getModuleFileName nullPtr buf len
233 if ret == 0 then return Nothing
234 else liftM Just $ peekCString buf
235 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
236
237 foreign import stdcall unsafe "GetModuleFileNameA"
238 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
239 #else
240 getExecPath = return Nothing
241 #endif