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