recent non-GHCs can use System.Cmd.rawSystem
[hsc2hs.git] / Main.hs
1 {-# OPTIONS -fffi -cpp #-}
2
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.63 2005/01/05 15:06:25 ross Exp $
5 --
6 -- Program for converting .hsc files to .hs files, by converting the
7 -- file into a C program which is run to generate the Haskell source.
8 -- Certain items known only to the C compiler can then be used in
9 -- the Haskell module; for example #defined constants, byte offsets
10 -- within structures, etc.
11 --
12 -- See the documentation in the Users' Guide for more details.
13
14 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
15 import System.Console.GetOpt
16 #else
17 import GetOpt
18 #endif
19
20 import System (getProgName, getArgs, ExitCode(..), exitWith, system)
21 import Directory (removeFile,doesFileExist)
22 import Monad (MonadPlus(..), liftM, liftM2, when)
23 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
24 import List (intersperse, isSuffixOf)
25 import IO (hPutStr, hPutStrLn, stderr)
26
27 #if defined(mingw32_HOST_OS)
28 import Foreign
29 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
30 import Foreign.C.String
31 #else
32 import CString
33 #endif
34 #endif
35
36
37 #ifdef __GLASGOW_HASKELL__
38 import Compat.RawSystem ( rawSystem )
39 #elif __HUGS__ || __NHC__ >= 117
40 import System.Cmd ( rawSystem )
41 #else
42 rawSystem prog args = system (prog++unwords args)
43 #endif
44
45 version :: String
46 version = "hsc2hs version 0.66\n"
47
48 data Flag
49 = Help
50 | Version
51 | Template String
52 | Compiler String
53 | Linker String
54 | CompFlag String
55 | LinkFlag String
56 | NoCompile
57 | Include String
58 | Define String (Maybe String)
59 | Output String
60 | Verbose
61
62 template_flag :: Flag -> Bool
63 template_flag (Template _) = True
64 template_flag _ = False
65
66 include :: String -> Flag
67 include s@('\"':_) = Include s
68 include s@('<' :_) = Include s
69 include s = Include ("\""++s++"\"")
70
71 define :: String -> Flag
72 define s = case break (== '=') s of
73 (name, []) -> Define name Nothing
74 (name, _:value) -> Define name (Just value)
75
76 options :: [OptDescr Flag]
77 options = [
78 Option ['o'] ["output"] (ReqArg Output "FILE")
79 "name of main output file",
80 Option ['t'] ["template"] (ReqArg Template "FILE")
81 "template file",
82 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
83 "C compiler to use",
84 Option ['l'] ["ld"] (ReqArg Linker "PROG")
85 "linker to use",
86 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
87 "flag to pass to the C compiler",
88 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
89 "passed to the C compiler",
90 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
91 "flag to pass to the linker",
92 Option ['i'] ["include"] (ReqArg include "FILE")
93 "as if placed in the source",
94 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
95 "as if placed in the source",
96 Option [] ["no-compile"] (NoArg NoCompile)
97 "stop after writing *_hsc_make.c",
98 Option ['v'] ["verbose"] (NoArg Verbose)
99 "dump commands to stderr",
100 Option ['?'] ["help"] (NoArg Help)
101 "display this help and exit",
102 Option ['V'] ["version"] (NoArg Version)
103 "output version information and exit" ]
104
105
106 main :: IO ()
107 main = do
108 prog <- getProgramName
109 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
110 args <- getArgs
111 let (flags, files, errs) = getOpt Permute options args
112
113 -- If there is no Template flag explicitly specified, try
114 -- to find one by looking near the executable. This only
115 -- works on Win32 (getExecDir). On Unix, there's a wrapper
116 -- script which specifies an explicit template flag.
117 flags_w_tpl <- if any template_flag flags then
118 return flags
119 else
120 do mb_path <- getExecDir "/bin/hsc2hs.exe"
121 add_opt <-
122 case mb_path of
123 Nothing -> return id
124 Just path -> do
125 let templ = path ++ "/template-hsc.h"
126 flg <- doesFileExist templ
127 if flg
128 then return ((Template templ):)
129 else return id
130 return (add_opt flags)
131 case (files, errs) of
132 (_, _)
133 | any isHelp flags_w_tpl -> bye (usageInfo header options)
134 | any isVersion flags_w_tpl -> bye version
135 where
136 isHelp Help = True; isHelp _ = False
137 isVersion Version = True; isVersion _ = False
138 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
139 (_, _ ) -> die (concat errs ++ usageInfo header options)
140
141 getProgramName :: IO String
142 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
143 where str `withoutSuffix` suff
144 | suff `isSuffixOf` str = take (length str - length suff) str
145 | otherwise = str
146
147 bye :: String -> IO a
148 bye s = putStr s >> exitWith ExitSuccess
149
150 die :: String -> IO a
151 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
152
153 processFile :: [Flag] -> String -> IO ()
154 processFile flags name
155 = do let file_name = dosifyPath name
156 s <- readFile file_name
157 case parser of
158 Parser p -> case p (SourcePos file_name 1) s of
159 Success _ _ _ toks -> output flags file_name toks
160 Failure (SourcePos name' line) msg ->
161 die (name'++":"++show line++": "++msg++"\n")
162
163 ------------------------------------------------------------------------
164 -- A deterministic parser which remembers the text which has been parsed.
165
166 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
167
168 data ParseResult a = Success !SourcePos String String a
169 | Failure !SourcePos String
170
171 data SourcePos = SourcePos String !Int
172
173 updatePos :: SourcePos -> Char -> SourcePos
174 updatePos pos@(SourcePos name line) ch = case ch of
175 '\n' -> SourcePos name (line + 1)
176 _ -> pos
177
178 instance Monad Parser where
179 return a = Parser $ \pos s -> Success pos [] s a
180 Parser m >>= k =
181 Parser $ \pos s -> case m pos s of
182 Success pos' out1 s' a -> case k a of
183 Parser k' -> case k' pos' s' of
184 Success pos'' out2 imp'' b ->
185 Success pos'' (out1++out2) imp'' b
186 Failure pos'' msg -> Failure pos'' msg
187 Failure pos' msg -> Failure pos' msg
188 fail msg = Parser $ \pos _ -> Failure pos msg
189
190 instance MonadPlus Parser where
191 mzero = fail "mzero"
192 Parser m `mplus` Parser n =
193 Parser $ \pos s -> case m pos s of
194 success@(Success _ _ _ _) -> success
195 Failure _ _ -> n pos s
196
197 getPos :: Parser SourcePos
198 getPos = Parser $ \pos s -> Success pos [] s pos
199
200 setPos :: SourcePos -> Parser ()
201 setPos pos = Parser $ \_ s -> Success pos [] s ()
202
203 message :: Parser a -> String -> Parser a
204 Parser m `message` msg =
205 Parser $ \pos s -> case m pos s of
206 success@(Success _ _ _ _) -> success
207 Failure pos' _ -> Failure pos' msg
208
209 catchOutput_ :: Parser a -> Parser String
210 catchOutput_ (Parser m) =
211 Parser $ \pos s -> case m pos s of
212 Success pos' out s' _ -> Success pos' [] s' out
213 Failure pos' msg -> Failure pos' msg
214
215 fakeOutput :: Parser a -> String -> Parser a
216 Parser m `fakeOutput` out =
217 Parser $ \pos s -> case m pos s of
218 Success pos' _ s' a -> Success pos' out s' a
219 Failure pos' msg -> Failure pos' msg
220
221 lookAhead :: Parser String
222 lookAhead = Parser $ \pos s -> Success pos [] s s
223
224 satisfy :: (Char -> Bool) -> Parser Char
225 satisfy p =
226 Parser $ \pos s -> case s of
227 c:cs | p c -> Success (updatePos pos c) [c] cs c
228 _ -> Failure pos "Bad character"
229
230 char_ :: Char -> Parser ()
231 char_ c = do
232 satisfy (== c) `message` (show c++" expected")
233 return ()
234
235 anyChar_ :: Parser ()
236 anyChar_ = do
237 satisfy (const True) `message` "Unexpected end of file"
238 return ()
239
240 any2Chars_ :: Parser ()
241 any2Chars_ = anyChar_ >> anyChar_
242
243 many :: Parser a -> Parser [a]
244 many p = many1 p `mplus` return []
245
246 many1 :: Parser a -> Parser [a]
247 many1 p = liftM2 (:) p (many p)
248
249 many_ :: Parser a -> Parser ()
250 many_ p = many1_ p `mplus` return ()
251
252 many1_ :: Parser a -> Parser ()
253 many1_ p = p >> many_ p
254
255 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
256 manySatisfy = many . satisfy
257 manySatisfy1 = many1 . satisfy
258
259 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
260 manySatisfy_ = many_ . satisfy
261 manySatisfy1_ = many1_ . satisfy
262
263 ------------------------------------------------------------------------
264 -- Parser of hsc syntax.
265
266 data Token
267 = Text SourcePos String
268 | Special SourcePos String String
269
270 parser :: Parser [Token]
271 parser = do
272 pos <- getPos
273 t <- catchOutput_ text
274 s <- lookAhead
275 rest <- case s of
276 [] -> return []
277 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
278 return (if null t then rest else Text pos t : rest)
279
280 text :: Parser ()
281 text = do
282 s <- lookAhead
283 case s of
284 [] -> return ()
285 c:_ | isAlpha c || c == '_' -> do
286 anyChar_
287 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
288 text
289 c:_ | isHsSymbol c -> do
290 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
291 case symb of
292 "#" -> return ()
293 '-':'-':symb' | all (== '-') symb' -> do
294 return () `fakeOutput` symb
295 manySatisfy_ (/= '\n')
296 text
297 _ -> do
298 return () `fakeOutput` unescapeHashes symb
299 text
300 '\"':_ -> do anyChar_; hsString '\"'; text
301 '\'':_ -> do anyChar_; hsString '\''; text
302 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
303 _:_ -> do anyChar_; text
304
305 hsString :: Char -> Parser ()
306 hsString quote = do
307 s <- lookAhead
308 case s of
309 [] -> return ()
310 c:_ | c == quote -> anyChar_
311 '\\':c:_
312 | isSpace c -> do
313 anyChar_
314 manySatisfy_ isSpace
315 char_ '\\' `mplus` return ()
316 hsString quote
317 | otherwise -> do any2Chars_; hsString quote
318 _:_ -> do anyChar_; hsString quote
319
320 hsComment :: Parser ()
321 hsComment = do
322 s <- lookAhead
323 case s of
324 [] -> return ()
325 '-':'}':_ -> any2Chars_
326 '{':'-':_ -> do any2Chars_; hsComment; hsComment
327 _:_ -> do anyChar_; hsComment
328
329 linePragma :: Parser ()
330 linePragma = do
331 char_ '#'
332 manySatisfy_ isSpace
333 satisfy (\c -> c == 'L' || c == 'l')
334 satisfy (\c -> c == 'I' || c == 'i')
335 satisfy (\c -> c == 'N' || c == 'n')
336 satisfy (\c -> c == 'E' || c == 'e')
337 manySatisfy1_ isSpace
338 line <- liftM read $ manySatisfy1 isDigit
339 manySatisfy1_ isSpace
340 char_ '\"'
341 name <- manySatisfy (/= '\"')
342 char_ '\"'
343 manySatisfy_ isSpace
344 char_ '#'
345 char_ '-'
346 char_ '}'
347 setPos (SourcePos name (line - 1))
348
349 isHsSymbol :: Char -> Bool
350 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
351 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
352 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
353 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
354 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
355 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
356 isHsSymbol '~' = True
357 isHsSymbol _ = False
358
359 unescapeHashes :: String -> String
360 unescapeHashes [] = []
361 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
362 unescapeHashes (c:s) = c : unescapeHashes s
363
364 lookAheadC :: Parser String
365 lookAheadC = liftM joinLines lookAhead
366 where
367 joinLines [] = []
368 joinLines ('\\':'\n':s) = joinLines s
369 joinLines (c:s) = c : joinLines s
370
371 satisfyC :: (Char -> Bool) -> Parser Char
372 satisfyC p = do
373 s <- lookAhead
374 case s of
375 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
376 _ -> satisfy p
377
378 charC_ :: Char -> Parser ()
379 charC_ c = do
380 satisfyC (== c) `message` (show c++" expected")
381 return ()
382
383 anyCharC_ :: Parser ()
384 anyCharC_ = do
385 satisfyC (const True) `message` "Unexpected end of file"
386 return ()
387
388 any2CharsC_ :: Parser ()
389 any2CharsC_ = anyCharC_ >> anyCharC_
390
391 manySatisfyC :: (Char -> Bool) -> Parser String
392 manySatisfyC = many . satisfyC
393
394 manySatisfyC_ :: (Char -> Bool) -> Parser ()
395 manySatisfyC_ = many_ . satisfyC
396
397 special :: Parser Token
398 special = do
399 manySatisfyC_ (\c -> isSpace c && c /= '\n')
400 s <- lookAheadC
401 case s of
402 '{':_ -> do
403 anyCharC_
404 manySatisfyC_ isSpace
405 sp <- keyArg (== '\n')
406 charC_ '}'
407 return sp
408 _ -> keyArg (const False)
409
410 keyArg :: (Char -> Bool) -> Parser Token
411 keyArg eol = do
412 pos <- getPos
413 key <- keyword `message` "hsc keyword or '{' expected"
414 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
415 arg <- catchOutput_ (argument eol)
416 return (Special pos key arg)
417
418 keyword :: Parser String
419 keyword = do
420 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
421 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
422 return (c:cs)
423
424 argument :: (Char -> Bool) -> Parser ()
425 argument eol = do
426 s <- lookAheadC
427 case s of
428 [] -> return ()
429 c:_ | eol c -> do anyCharC_; argument eol
430 '\n':_ -> return ()
431 '\"':_ -> do anyCharC_; cString '\"'; argument eol
432 '\'':_ -> do anyCharC_; cString '\''; argument eol
433 '(':_ -> do anyCharC_; nested ')'; argument eol
434 ')':_ -> return ()
435 '/':'*':_ -> do any2CharsC_; cComment; argument eol
436 '/':'/':_ -> do
437 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
438 '[':_ -> do anyCharC_; nested ']'; argument eol
439 ']':_ -> return ()
440 '{':_ -> do anyCharC_; nested '}'; argument eol
441 '}':_ -> return ()
442 _:_ -> do anyCharC_; argument eol
443
444 nested :: Char -> Parser ()
445 nested c = do argument (== '\n'); charC_ c
446
447 cComment :: Parser ()
448 cComment = do
449 s <- lookAheadC
450 case s of
451 [] -> return ()
452 '*':'/':_ -> do any2CharsC_
453 _:_ -> do anyCharC_; cComment
454
455 cString :: Char -> Parser ()
456 cString quote = do
457 s <- lookAheadC
458 case s of
459 [] -> return ()
460 c:_ | c == quote -> anyCharC_
461 '\\':_:_ -> do any2CharsC_; cString quote
462 _:_ -> do anyCharC_; cString quote
463
464 ------------------------------------------------------------------------
465 -- Write the output files.
466
467 splitName :: String -> (String, String)
468 splitName name =
469 case break (== '/') name of
470 (file, []) -> ([], file)
471 (dir, sep:rest) -> (dir++sep:restDir, restFile)
472 where
473 (restDir, restFile) = splitName rest
474
475 splitExt :: String -> (String, String)
476 splitExt name =
477 case break (== '.') name of
478 (base, []) -> (base, [])
479 (base, sepRest@(sep:rest))
480 | null restExt -> (base, sepRest)
481 | otherwise -> (base++sep:restBase, restExt)
482 where
483 (restBase, restExt) = splitExt rest
484
485 output :: [Flag] -> String -> [Token] -> IO ()
486 output flags name toks = do
487
488 (outName, outDir, outBase) <- case [f | Output f <- flags] of
489 [] -> if not (null ext) && last ext == 'c'
490 then return (dir++base++init ext, dir, base)
491 else
492 if ext == ".hs"
493 then return (dir++base++"_out.hs", dir, base)
494 else return (dir++base++".hs", dir, base)
495 where
496 (dir, file) = splitName name
497 (base, ext) = splitExt file
498 [f] -> let
499 (dir, file) = splitName f
500 (base, _) = splitExt file
501 in return (f, dir, base)
502 _ -> onlyOne "output file"
503
504 let cProgName = outDir++outBase++"_hsc_make.c"
505 oProgName = outDir++outBase++"_hsc_make.o"
506 progName = outDir++outBase++"_hsc_make"
507 #if defined(mingw32_HOST_OS)
508 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
509 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
510 ++ ".exe"
511 #endif
512 outHFile = outBase++"_hsc.h"
513 outHName = outDir++outHFile
514 outCName = outDir++outBase++"_hsc.c"
515
516 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
517
518 let execProgName
519 | null outDir = dosifyPath ("./" ++ progName)
520 | otherwise = progName
521
522 let specials = [(pos, key, arg) | Special pos key arg <- toks]
523
524 let needsC = any (\(_, key, _) -> key == "def") specials
525 needsH = needsC
526
527 let includeGuard = map fixChar outHName
528 where
529 fixChar c | isAlphaNum c = toUpper c
530 | otherwise = '_'
531
532 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
533 -- Returns a native-format path
534 locateGhc def = do
535 mb <- getExecDir "bin/hsc2hs.exe"
536 case mb of
537 Nothing -> return def
538 Just x -> do
539 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
540 flg <- doesFileExist ghc_path
541 if flg
542 then return ghc_path
543 else return def
544
545 -- On a Win32 installation we execute the hsc2hs binary directly,
546 -- with no --cc flags, so we'll call locateGhc here, which will
547 -- succeed, via getExecDir.
548 --
549 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
550 -- (called plain hsc2hs in the installed tree), which will pass
551 -- a suitable C compiler via --cc
552 --
553 -- The in-place installation always uses the wrapper script,
554 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
555 compiler <- case [c | Compiler c <- flags] of
556 [] -> locateGhc "ghc"
557 [c] -> return c
558 _ -> onlyOne "compiler"
559
560 linker <- case [l | Linker l <- flags] of
561 [] -> locateGhc compiler
562 [l] -> return l
563 _ -> onlyOne "linker"
564
565 writeFile cProgName $
566 concatMap outFlagHeaderCProg flags++
567 concatMap outHeaderCProg specials++
568 "\nint main (int argc, char *argv [])\n{\n"++
569 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
570 outHsLine (SourcePos name 0)++
571 concatMap outTokenHs toks++
572 " return 0;\n}\n"
573
574 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
575 -- so we use something slightly more complicated. :-P
576 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
577 exitWith ExitSuccess
578
579
580
581 compilerStatus <- rawSystemL beVerbose compiler
582 ( ["-c"]
583 ++ [f | CompFlag f <- flags]
584 ++ [cProgName]
585 ++ ["-o", oProgName]
586 )
587
588 case compilerStatus of
589 e@(ExitFailure _) -> exitWith e
590 _ -> return ()
591 removeFile cProgName
592
593 linkerStatus <- rawSystemL beVerbose linker
594 ( [f | LinkFlag f <- flags]
595 ++ [oProgName]
596 ++ ["-o", progName]
597 )
598
599 case linkerStatus of
600 e@(ExitFailure _) -> exitWith e
601 _ -> return ()
602 removeFile oProgName
603
604 progStatus <- systemL beVerbose (execProgName++" >"++outName)
605 removeFile progName
606 case progStatus of
607 e@(ExitFailure _) -> exitWith e
608 _ -> return ()
609
610 when needsH $ writeFile outHName $
611 "#ifndef "++includeGuard++"\n" ++
612 "#define "++includeGuard++"\n" ++
613 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
614 "#include <Rts.h>\n" ++
615 "#endif\n" ++
616 "#include <HsFFI.h>\n" ++
617 "#if __NHC__\n" ++
618 "#undef HsChar\n" ++
619 "#define HsChar int\n" ++
620 "#endif\n" ++
621 concatMap outFlagH flags++
622 concatMap outTokenH specials++
623 "#endif\n"
624
625 when needsC $ writeFile outCName $
626 "#include \""++outHFile++"\"\n"++
627 concatMap outTokenC specials
628 -- NB. outHFile not outHName; works better when processed
629 -- by gcc or mkdependC.
630
631 rawSystemL :: Bool -> String -> [String] -> IO ExitCode
632 rawSystemL flg prog args = do
633 when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
634 rawSystem prog args
635
636 systemL :: Bool -> String -> IO ExitCode
637 systemL flg s = do
638 when flg (hPutStrLn stderr ("Executing: " ++ s))
639 system s
640
641 onlyOne :: String -> IO a
642 onlyOne what = die ("Only one "++what++" may be specified\n")
643
644 outFlagHeaderCProg :: Flag -> String
645 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
646 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
647 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
648 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
649 outFlagHeaderCProg _ = ""
650
651 outHeaderCProg :: (SourcePos, String, String) -> String
652 outHeaderCProg (pos, key, arg) = case key of
653 "include" -> outCLine pos++"#include "++arg++"\n"
654 "define" -> outCLine pos++"#define "++arg++"\n"
655 "undef" -> outCLine pos++"#undef "++arg++"\n"
656 "def" -> case arg of
657 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
658 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
659 _ -> ""
660 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
661 "let" -> case break (== '=') arg of
662 (_, "") -> ""
663 (header, _:body) -> case break isSpace header of
664 (name, args) ->
665 outCLine pos++
666 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
667 "printf ("++joinLines body++");\n"
668 _ -> ""
669 where
670 joinLines = concat . intersperse " \\\n" . lines
671
672 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
673 outHeaderHs flags inH toks =
674 "#if " ++
675 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
676 " printf (\"{-# OPTIONS -optc-D" ++
677 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
678 "__GLASGOW_HASKELL__);\n" ++
679 "#endif\n"++
680 case inH of
681 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
682 Just f -> outOption ("-#include \""++f++"\"")
683 where
684 outFlag (Include f) = outOption ("-#include "++f)
685 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
686 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
687 outFlag _ = ""
688 outSpecial (pos, key, arg) = case key of
689 "include" -> outOption ("-#include "++arg)
690 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
691 | otherwise -> ""
692 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
693 _ -> ""
694 goodForOptD arg = case arg of
695 "" -> True
696 c:_ | isSpace c -> True
697 '(':_ -> False
698 _:s -> goodForOptD s
699 toOptD arg = case break isSpace arg of
700 (name, "") -> name
701 (name, _:value) -> name++'=':dropWhile isSpace value
702 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
703 showCString s++"\");\n"
704
705 outTokenHs :: Token -> String
706 outTokenHs (Text pos txt) =
707 case break (== '\n') txt of
708 (allTxt, []) -> outText allTxt
709 (first, _:rest) ->
710 outText (first++"\n")++
711 outHsLine pos++
712 outText rest
713 where
714 outText s = " fputs (\""++showCString s++"\", stdout);\n"
715 outTokenHs (Special pos key arg) =
716 case key of
717 "include" -> ""
718 "define" -> ""
719 "undef" -> ""
720 "def" -> ""
721 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
722 "let" -> ""
723 "enum" -> outCLine pos++outEnum arg
724 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
725
726 outEnum :: String -> String
727 outEnum arg =
728 case break (== ',') arg of
729 (_, []) -> ""
730 (t, _:afterT) -> case break (== ',') afterT of
731 (f, afterF) -> let
732 enums [] = ""
733 enums (_:s) = case break (== ',') s of
734 (enum, rest) -> let
735 this = case break (== '=') $ dropWhile isSpace enum of
736 (name, []) ->
737 " hsc_enum ("++t++", "++f++", " ++
738 "hsc_haskellize (\""++name++"\"), "++
739 name++");\n"
740 (hsName, _:cName) ->
741 " hsc_enum ("++t++", "++f++", " ++
742 "printf (\"%s\", \""++hsName++"\"), "++
743 cName++");\n"
744 in this++enums rest
745 in enums afterF
746
747 outFlagH :: Flag -> String
748 outFlagH (Include f) = "#include "++f++"\n"
749 outFlagH (Define n Nothing) = "#define "++n++"\n"
750 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
751 outFlagH _ = ""
752
753 outTokenH :: (SourcePos, String, String) -> String
754 outTokenH (pos, key, arg) =
755 case key of
756 "include" -> outCLine pos++"#include "++arg++"\n"
757 "define" -> outCLine pos++"#define " ++arg++"\n"
758 "undef" -> outCLine pos++"#undef " ++arg++"\n"
759 "def" -> outCLine pos++case arg of
760 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
761 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
762 'i':'n':'l':'i':'n':'e':' ':_ ->
763 "#ifdef __GNUC__\n" ++
764 "extern\n" ++
765 "#endif\n"++
766 arg++"\n"
767 _ -> "extern "++header++";\n"
768 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
769 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
770 _ -> ""
771
772 outTokenC :: (SourcePos, String, String) -> String
773 outTokenC (pos, key, arg) =
774 case key of
775 "def" -> case arg of
776 's':'t':'r':'u':'c':'t':' ':_ -> ""
777 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
778 'i':'n':'l':'i':'n':'e':' ':arg' ->
779 case span (\c -> c /= '{' && c /= '=') arg' of
780 (header, body) ->
781 outCLine pos++
782 "#ifndef __GNUC__\n" ++
783 "extern inline\n" ++
784 "#endif\n"++
785 header++
786 "\n#ifndef __GNUC__\n" ++
787 ";\n" ++
788 "#else\n"++
789 body++
790 "\n#endif\n"
791 _ -> outCLine pos++arg++"\n"
792 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
793 _ -> ""
794
795 conditional :: String -> Bool
796 conditional "if" = True
797 conditional "ifdef" = True
798 conditional "ifndef" = True
799 conditional "elif" = True
800 conditional "else" = True
801 conditional "endif" = True
802 conditional "error" = True
803 conditional "warning" = True
804 conditional _ = False
805
806 outCLine :: SourcePos -> String
807 outCLine (SourcePos name line) =
808 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
809
810 outHsLine :: SourcePos -> String
811 outHsLine (SourcePos name line) =
812 " hsc_line ("++show (line + 1)++", \""++
813 showCString (snd (splitName name))++"\");\n"
814
815 showCString :: String -> String
816 showCString = concatMap showCChar
817 where
818 showCChar '\"' = "\\\""
819 showCChar '\'' = "\\\'"
820 showCChar '?' = "\\?"
821 showCChar '\\' = "\\\\"
822 showCChar c | c >= ' ' && c <= '~' = [c]
823 showCChar '\a' = "\\a"
824 showCChar '\b' = "\\b"
825 showCChar '\f' = "\\f"
826 showCChar '\n' = "\\n\"\n \""
827 showCChar '\r' = "\\r"
828 showCChar '\t' = "\\t"
829 showCChar '\v' = "\\v"
830 showCChar c = ['\\',
831 intToDigit (ord c `quot` 64),
832 intToDigit (ord c `quot` 8 `mod` 8),
833 intToDigit (ord c `mod` 8)]
834
835
836
837 -----------------------------------------
838 -- Cut and pasted from ghc/compiler/SysTools
839 -- Convert paths foo/baz to foo\baz on Windows
840
841 dosifyPath :: String -> String
842 #if defined(mingw32_HOST_OS)
843 dosifyPath xs = subst '/' '\\' xs
844
845 unDosifyPath :: String -> String
846 unDosifyPath xs = subst '\\' '/' xs
847
848 subst :: Eq a => a -> a -> [a] -> [a]
849 subst a b ls = map (\ x -> if x == a then b else x) ls
850
851 getExecDir :: String -> IO (Maybe String)
852 -- (getExecDir cmd) returns the directory in which the current
853 -- executable, which should be called 'cmd', is running
854 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
855 -- you'll get "/a/b/c" back as the result
856 getExecDir cmd
857 = allocaArray len $ \buf -> do
858 ret <- getModuleFileName nullPtr buf len
859 if ret == 0 then return Nothing
860 else do s <- peekCString buf
861 return (Just (reverse (drop (length cmd)
862 (reverse (unDosifyPath s)))))
863 where
864 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
865
866 foreign import stdcall unsafe "GetModuleFileNameA"
867 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
868
869 #else
870 dosifyPath xs = xs
871
872 getExecDir :: String -> IO (Maybe String)
873 getExecDir _ = return Nothing
874 #endif