More refactoring
[hsc2hs.git] / DirectCodegen.hs
1 {-# LANGUAGE CPP #-}
2 module DirectCodegen where
3
4 {-
5 The standard mode for hsc2hs: generates a C file which is
6 compiled and run; the output of that program is the .hs file.
7 -}
8
9 import Control.Exception ( bracket_ )
10 import qualified Control.Exception as Exception
11 import Data.Char ( isAlphaNum, isSpace, intToDigit,
12 toUpper, ord )
13 import Data.List ( intersperse )
14 import HSCParser ( SourcePos(..), Token(..) )
15 import Control.Monad ( when )
16 import System.IO
17
18 #if __GLASGOW_HASKELL__ >= 604
19 import System.Process ( runProcess, waitForProcess )
20 #define HAVE_runProcess
21 #endif
22
23 import System.Cmd ( rawSystem )
24 #ifndef HAVE_runProcess
25 import System.Cmd ( system )
26 #endif
27
28 import System.Exit ( ExitCode(..), exitWith )
29 import System.Directory ( removeFile )
30
31 data Flag
32 = Help
33 | Version
34 | Template String
35 | Compiler String
36 | Linker String
37 | CompFlag String
38 | LinkFlag String
39 | NoCompile
40 | Include String
41 | Define String (Maybe String)
42 | Output String
43 | KeepFiles
44 | Verbose
45
46 die :: String -> IO a
47 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
48
49 default_compiler :: String
50 default_compiler = "gcc"
51
52 ------------------------------------------------------------------------
53 -- Write the output files.
54
55 splitName :: String -> (String, String)
56 splitName name =
57 case break (== '/') name of
58 (file, []) -> ([], file)
59 (dir, sep:rest) -> (dir++sep:restDir, restFile)
60 where
61 (restDir, restFile) = splitName rest
62
63 splitExt :: String -> (String, String)
64 splitExt name =
65 case break (== '.') name of
66 (base, []) -> (base, [])
67 (base, sepRest@(sep:rest))
68 | null restExt -> (base, sepRest)
69 | otherwise -> (base++sep:restBase, restExt)
70 where
71 (restBase, restExt) = splitExt rest
72
73 output :: [Flag] -> FilePath -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO ()
74 output flags compiler outName outDir outBase name toks = do
75
76 let cProgName = outDir++outBase++"_hsc_make.c"
77 oProgName = outDir++outBase++"_hsc_make.o"
78 progName = outDir++outBase++"_hsc_make"
79 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
80 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
81 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
82 ++ ".exe"
83 #endif
84 outHFile = outBase++"_hsc.h"
85 outHName = outDir++outHFile
86 outCName = outDir++outBase++"_hsc.c"
87
88 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
89
90 let execProgName
91 | null outDir = dosifyPath ("./" ++ progName)
92 | otherwise = progName
93
94 let specials = [(pos, key, arg) | Special pos key arg <- toks]
95
96 let needsC = any (\(_, key, _) -> key == "def") specials
97 needsH = needsC
98 keepFiles = not $ null [() | KeepFiles <- flags]
99 possiblyRemove = if keepFiles
100 then flip const
101 else finallyRemove
102
103 let includeGuard = map fixChar outHName
104 where
105 fixChar c | isAlphaNum c = toUpper c
106 | otherwise = '_'
107
108 linker <- case [l | Linker l <- flags] of
109 [] -> return compiler
110 ls -> return (last ls)
111
112 writeBinaryFile cProgName $
113 concatMap outFlagHeaderCProg flags++
114 concatMap outHeaderCProg specials++
115 "\nint main (int argc, char *argv [])\n{\n"++
116 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
117 outHsLine (SourcePos name 0)++
118 concatMap outTokenHs toks++
119 " return 0;\n}\n"
120
121 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
122 -- so we use something slightly more complicated. :-P
123 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
124 exitWith ExitSuccess
125
126 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
127 ( ["-c"]
128 ++ [cProgName]
129 ++ ["-o", oProgName]
130 ++ [f | CompFlag f <- flags]
131 )
132 possiblyRemove cProgName $ do
133
134 rawSystemL ("linking " ++ oProgName) beVerbose linker
135 ( [oProgName]
136 ++ ["-o", progName]
137 ++ [f | LinkFlag f <- flags]
138 )
139 possiblyRemove oProgName $ do
140
141 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
142 possiblyRemove progName $ do
143
144 when needsH $ writeBinaryFile outHName $
145 "#ifndef "++includeGuard++"\n" ++
146 "#define "++includeGuard++"\n" ++
147 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
148 "#include <Rts.h>\n" ++
149 "#endif\n" ++
150 "#include <HsFFI.h>\n" ++
151 "#if __NHC__\n" ++
152 "#undef HsChar\n" ++
153 "#define HsChar int\n" ++
154 "#endif\n" ++
155 concatMap outFlagH flags++
156 concatMap outTokenH specials++
157 "#endif\n"
158
159 when needsC $ writeBinaryFile outCName $
160 "#include \""++outHFile++"\"\n"++
161 concatMap outTokenC specials
162 -- NB. outHFile not outHName; works better when processed
163 -- by gcc or mkdependC.
164
165 writeBinaryFile :: FilePath -> String -> IO ()
166 writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
167
168 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
169 rawSystemL action flg prog args = do
170 let cmdLine = prog++" "++unwords args
171 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
172 exitStatus <- rawSystem prog args
173 case exitStatus of
174 ExitFailure exitCode -> die $ action ++ " failed "
175 ++ "(exit code " ++ show exitCode ++ ")\n"
176 ++ "command was: " ++ cmdLine ++ "\n"
177 _ -> return ()
178
179 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
180 rawSystemWithStdOutL action flg prog args outFile = do
181 let cmdLine = prog++" "++unwords args++" >"++outFile
182 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
183 #ifndef HAVE_runProcess
184 exitStatus <- system cmdLine
185 #else
186 hOut <- openFile outFile WriteMode
187 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
188 exitStatus <- waitForProcess process
189 hClose hOut
190 #endif
191 case exitStatus of
192 ExitFailure exitCode -> die $ action ++ " failed "
193 ++ "(exit code " ++ show exitCode ++ ")\n"
194 ++ "command was: " ++ cmdLine ++ "\n"
195 _ -> return ()
196
197 -- delay the cleanup of generated files until the end; attempts to
198 -- get around intermittent failure to delete files which has
199 -- just been exec'ed by a sub-process (Win32 only.)
200 finallyRemove :: FilePath -> IO a -> IO a
201 finallyRemove fp act =
202 bracket_ (return fp)
203 (noisyRemove fp)
204 act
205 where
206 noisyRemove fpath =
207 catchIO (removeFile fpath)
208 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
209
210 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
211 catchIO = Exception.catch
212
213 onlyOne :: String -> IO a
214 onlyOne what = die ("Only one "++what++" may be specified\n")
215
216 outFlagHeaderCProg :: Flag -> String
217 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
218 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
219 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
220 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
221 outFlagHeaderCProg _ = ""
222
223 outHeaderCProg :: (SourcePos, String, String) -> String
224 outHeaderCProg (pos, key, arg) = case key of
225 "include" -> outCLine pos++"#include "++arg++"\n"
226 "define" -> outCLine pos++"#define "++arg++"\n"
227 "undef" -> outCLine pos++"#undef "++arg++"\n"
228 "def" -> case arg of
229 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
230 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
231 _ -> ""
232 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
233 "let" -> case break (== '=') arg of
234 (_, "") -> ""
235 (header, _:body) -> case break isSpace header of
236 (name, args) ->
237 outCLine pos++
238 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
239 "printf ("++joinLines body++");\n"
240 _ -> ""
241 where
242 joinLines = concat . intersperse " \\\n" . lines
243
244 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
245 outHeaderHs flags inH toks =
246 "#if " ++
247 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
248 " printf (\"{-# OPTIONS -optc-D" ++
249 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
250 "__GLASGOW_HASKELL__);\n" ++
251 "#endif\n"++
252 case inH of
253 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
254 Just f -> outInclude ("\""++f++"\"")
255 where
256 outFlag (Include f) = outInclude f
257 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
258 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
259 outFlag _ = ""
260 outSpecial (pos, key, arg) = case key of
261 "include" -> outInclude arg
262 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
263 | otherwise -> ""
264 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
265 _ -> ""
266 goodForOptD arg = case arg of
267 "" -> True
268 c:_ | isSpace c -> True
269 '(':_ -> False
270 _:s -> goodForOptD s
271 toOptD arg = case break isSpace arg of
272 (name, "") -> name
273 (name, _:value) -> name++'=':dropWhile isSpace value
274 outOption s =
275 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
276 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
277 showCString s++"\");\n"++
278 "#else\n"++
279 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
280 showCString s++"\");\n"++
281 "#endif\n"
282 outInclude s =
283 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
284 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
285 showCString s++"\");\n"++
286 "#elif __GLASGOW_HASKELL__ < 610\n"++
287 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
288 showCString s++"\");\n"++
289 "#endif\n"
290
291 outTokenHs :: Token -> String
292 outTokenHs (Text pos txt) =
293 case break (== '\n') txt of
294 (allTxt, []) -> outText allTxt
295 (first, _:rest) ->
296 outText (first++"\n")++
297 outHsLine pos++
298 outText rest
299 where
300 outText s = " fputs (\""++showCString s++"\", stdout);\n"
301 outTokenHs (Special pos key arg) =
302 case key of
303 "include" -> ""
304 "define" -> ""
305 "undef" -> ""
306 "def" -> ""
307 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
308 "let" -> ""
309 "enum" -> outCLine pos++outEnum arg
310 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
311
312 parseEnum :: String -> Maybe (String,String,[(Maybe String,String)])
313 parseEnum arg =
314 case break (== ',') arg of
315 (_, []) -> Nothing
316 (t, _:afterT) -> case break (== ',') afterT of
317 (f, afterF) -> let
318 enums [] = []
319 enums (_:s) = case break (== ',') s of
320 (enum, rest) -> let
321 this = case break (== '=') $ dropWhile isSpace enum of
322 (name, []) -> (Nothing, name)
323 (hsName, _:cName) -> (Just hsName, cName)
324 in this:enums rest
325 in Just (t, f, enums afterF)
326
327 outEnum :: String -> String
328 outEnum arg = case parseEnum arg of
329 Nothing -> ""
330 Just (t,f,enums) ->
331 flip concatMap enums $ \(maybeHsName, cName) ->
332 case maybeHsName of
333 Nothing ->
334 " hsc_enum ("++t++", "++f++", " ++
335 "hsc_haskellize (\""++cName++"\"), "++
336 cName++");\n"
337 Just hsName ->
338 " hsc_enum ("++t++", "++f++", " ++
339 "printf (\"%s\", \""++hsName++"\"), "++
340 cName++");\n"
341
342 outFlagH :: Flag -> String
343 outFlagH (Include f) = "#include "++f++"\n"
344 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
345 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
346 outFlagH _ = ""
347
348 outTokenH :: (SourcePos, String, String) -> String
349 outTokenH (pos, key, arg) =
350 case key of
351 "include" -> outCLine pos++"#include "++arg++"\n"
352 "define" -> outCLine pos++"#define " ++arg++"\n"
353 "undef" -> outCLine pos++"#undef " ++arg++"\n"
354 "def" -> outCLine pos++case arg of
355 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
356 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
357 'i':'n':'l':'i':'n':'e':' ':_ ->
358 "#ifdef __GNUC__\n" ++
359 "extern\n" ++
360 "#endif\n"++
361 arg++"\n"
362 _ -> "extern "++header++";\n"
363 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
364 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
365 _ -> ""
366
367 outTokenC :: (SourcePos, String, String) -> String
368 outTokenC (pos, key, arg) =
369 case key of
370 "def" -> case arg of
371 's':'t':'r':'u':'c':'t':' ':_ -> ""
372 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
373 'i':'n':'l':'i':'n':'e':' ':arg' ->
374 case span (\c -> c /= '{' && c /= '=') arg' of
375 (header, body) ->
376 outCLine pos++
377 "#ifndef __GNUC__\n" ++
378 "extern inline\n" ++
379 "#endif\n"++
380 header++
381 "\n#ifndef __GNUC__\n" ++
382 ";\n" ++
383 "#else\n"++
384 body++
385 "\n#endif\n"
386 _ -> outCLine pos++arg++"\n"
387 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
388 _ -> ""
389
390 conditional :: String -> Bool
391 conditional "if" = True
392 conditional "ifdef" = True
393 conditional "ifndef" = True
394 conditional "elif" = True
395 conditional "else" = True
396 conditional "endif" = True
397 conditional "error" = True
398 conditional "warning" = True
399 conditional _ = False
400
401 outCLine :: SourcePos -> String
402 outCLine (SourcePos name line) =
403 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
404
405 outHsLine :: SourcePos -> String
406 outHsLine (SourcePos name line) =
407 " hsc_line ("++show (line + 1)++", \""++
408 showCString name++"\");\n"
409
410 showCString :: String -> String
411 showCString = concatMap showCChar
412 where
413 showCChar '\"' = "\\\""
414 showCChar '\'' = "\\\'"
415 showCChar '?' = "\\?"
416 showCChar '\\' = "\\\\"
417 showCChar c | c >= ' ' && c <= '~' = [c]
418 showCChar '\a' = "\\a"
419 showCChar '\b' = "\\b"
420 showCChar '\f' = "\\f"
421 showCChar '\n' = "\\n\"\n \""
422 showCChar '\r' = "\\r"
423 showCChar '\t' = "\\t"
424 showCChar '\v' = "\\v"
425 showCChar c = ['\\',
426 intToDigit (ord c `quot` 64),
427 intToDigit (ord c `quot` 8 `mod` 8),
428 intToDigit (ord c `mod` 8)]
429
430 -----------------------------------------
431 -- Modified version from ghc/compiler/SysTools
432 -- Convert paths foo/baz to foo\baz on Windows
433
434 subst :: Char -> Char -> String -> String
435 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
436 subst a b = map (\x -> if x == a then b else x)
437 #else
438 subst _ _ = id
439 #endif
440
441 dosifyPath :: String -> String
442 dosifyPath = subst '/' '\\'
443
444 unDosifyPath :: String -> String
445 unDosifyPath = subst '\\' '/'
446