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