Add a runParser function; part of the patch from Brian Bloniarz
[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 )
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 processFiles :: [Flag] -> [FilePath] -> String -> IO ()
113 processFiles flags files usage = do
114 mb_libdir <- getLibDir
115
116 -- If there's no template specified on the commandline, try to locate it
117 flags_w_tpl <- case filter template_flag flags of
118 [_] -> return flags
119 (_:_) -> -- take only the last --template flag on the cmd line
120 let (before,tpl:after) = break template_flag (reverse flags)
121 in return $ reverse (before ++ tpl : filter (not.template_flag) after)
122 [] -> do -- If there is no Template flag explicitly specified, try
123 -- to find one. We first look near the executable. This only
124 -- works on Win32 or Hugs (getExecDir). If this finds a template
125 -- file then it's certainly the one we want, even if hsc2hs isn't
126 -- installed where we told Cabal it would be installed.
127 --
128 -- Next we try the location we told Cabal about.
129 --
130 -- If neither of the above work, then hopefully we're on Unix and
131 -- there's a wrapper script which specifies an explicit template flag.
132 mb_templ1 <-
133 case mb_libdir of
134 Nothing -> return Nothing
135 Just path -> do
136 -- Euch, this is horrible. Unfortunately
137 -- Paths_hsc2hs isn't too useful for a
138 -- relocatable binary, though.
139 let
140 #if defined(NEW_GHC_LAYOUT)
141 templ1 = path ++ "/template-hsc.h"
142 #else
143 templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h"
144 #endif
145 incl = path ++ "/include/"
146 exists1 <- doesFileExist templ1
147 if exists1
148 then return $ Just (Template templ1,
149 CompFlag ("-I" ++ incl))
150 else return Nothing
151 case mb_templ1 of
152 Just (templ1, incl) -> return (templ1 : flags ++ [incl])
153 Nothing -> do
154 templ2 <- getDataFileName "template-hsc.h"
155 exists2 <- doesFileExist templ2
156 if exists2 then return (Template templ2 : flags)
157 else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage)
158 mapM_ (processFile flags_w_tpl mb_libdir) files
159
160 getProgramName :: IO String
161 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
162 where str `withoutSuffix` suff
163 | suff `isSuffixOf` str = take (length str - length suff) str
164 | otherwise = str
165
166 bye :: String -> IO a
167 bye s = putStr s >> exitWith ExitSuccess
168
169 processFile :: [Flag] -> Maybe String -> String -> IO ()
170 processFile flags mb_libdir name
171 = do let file_name = dosifyPath name
172 h <- openBinaryFile file_name ReadMode
173 -- use binary mode so we pass through UTF-8, see GHC ticket #3837
174 -- But then on Windows we end up turning things like
175 -- #let alignment t = e^M
176 -- into
177 -- #define hsc_alignment(t ) printf ( e^M);
178 -- which gcc doesn't like, so strip out any ^M characters.
179 s <- hGetContents h
180 let s' = filter ('\r' /=) s
181 case runParser parser file_name s' of
182 Success _ _ _ toks -> output mb_libdir flags file_name toks
183 Failure (SourcePos name' line) msg ->
184 die (name'++":"++show line++": "++msg++"\n")
185
186 getLibDir :: IO (Maybe String)
187 #if defined(NEW_GHC_LAYOUT)
188 getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
189 #else
190 getLibDir = getExecDir "/bin/hsc2hs.exe"
191 #endif
192
193 -- (getExecDir cmd) returns the directory in which the current
194 -- executable, which should be called 'cmd', is running
195 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
196 -- you'll get "/a/b/c" back as the result
197 getExecDir :: String -> IO (Maybe String)
198 getExecDir cmd =
199 getExecPath >>= maybe (return Nothing) removeCmdSuffix
200 where initN n = reverse . drop n . reverse
201 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
202
203 getExecPath :: IO (Maybe String)
204 #if defined(mingw32_HOST_OS)
205 getExecPath =
206 allocaArray len $ \buf -> do
207 ret <- getModuleFileName nullPtr buf len
208 if ret == 0 then return Nothing
209 else liftM Just $ peekCString buf
210 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
211
212 foreign import stdcall unsafe "GetModuleFileNameA"
213 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
214 #else
215 getExecPath = return Nothing
216 #endif