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