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