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