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