1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.67 2005/01/24 00:36:03 ross Exp $
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.
12 -- See the documentation in the Users' Guide for more details.
14 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
15 import System.Console.GetOpt
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)
27 #if defined(mingw32_HOST_OS) && !__HUGS__
29 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
30 import Foreign.C.String
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 )
42 rawSystem prog args = system (prog++" "++unwords args)
46 version = "hsc2hs version 0.66\n"
58 | Define String (Maybe String)
62 template_flag :: Flag -> Bool
63 template_flag (Template _) = True
64 template_flag _ = False
66 include :: String -> Flag
67 include s@('\"':_) = Include s
68 include s@('<' :_) = Include s
69 include s = Include ("\""++s++"\"")
71 define :: String -> Flag
72 define s = case break (== '=') s of
73 (name, []) -> Define name Nothing
74 (name, _:value) -> Define name (Just value)
76 options :: [OptDescr Flag]
78 Option ['o'] ["output"] (ReqArg Output "FILE")
79 "name of main output file",
80 Option ['t'] ["template"] (ReqArg Template "FILE")
82 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
84 Option ['l'] ["ld"] (ReqArg Linker "PROG")
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" ]
108 prog <- getProgramName
109 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
111 let (flags, files, errs) = getOpt Permute options args
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 or Hugs (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
121 do mb_path <- getExecDir "/Main.hs"
123 do mb_path <- getExecDir "/bin/hsc2hs.exe"
129 let templ = path ++ "/template-hsc.h"
130 flg <- doesFileExist templ
132 then return ((Template templ):)
134 return (add_opt flags)
135 case (files, errs) of
137 | any isHelp flags_w_tpl -> bye (usageInfo header options)
138 | any isVersion flags_w_tpl -> bye version
140 isHelp Help = True; isHelp _ = False
141 isVersion Version = True; isVersion _ = False
142 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
143 (_, _ ) -> die (concat errs ++ usageInfo header options)
145 getProgramName :: IO String
146 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
147 where str `withoutSuffix` suff
148 | suff `isSuffixOf` str = take (length str - length suff) str
151 bye :: String -> IO a
152 bye s = putStr s >> exitWith ExitSuccess
154 die :: String -> IO a
155 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
157 processFile :: [Flag] -> String -> IO ()
158 processFile flags name
159 = do let file_name = dosifyPath name
160 s <- readFile file_name
162 Parser p -> case p (SourcePos file_name 1) s of
163 Success _ _ _ toks -> output flags file_name toks
164 Failure (SourcePos name' line) msg ->
165 die (name'++":"++show line++": "++msg++"\n")
167 ------------------------------------------------------------------------
168 -- A deterministic parser which remembers the text which has been parsed.
170 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
172 data ParseResult a = Success !SourcePos String String a
173 | Failure !SourcePos String
175 data SourcePos = SourcePos String !Int
177 updatePos :: SourcePos -> Char -> SourcePos
178 updatePos pos@(SourcePos name line) ch = case ch of
179 '\n' -> SourcePos name (line + 1)
182 instance Monad Parser where
183 return a = Parser $ \pos s -> Success pos [] s a
185 Parser $ \pos s -> case m pos s of
186 Success pos' out1 s' a -> case k a of
187 Parser k' -> case k' pos' s' of
188 Success pos'' out2 imp'' b ->
189 Success pos'' (out1++out2) imp'' b
190 Failure pos'' msg -> Failure pos'' msg
191 Failure pos' msg -> Failure pos' msg
192 fail msg = Parser $ \pos _ -> Failure pos msg
194 instance MonadPlus Parser where
196 Parser m `mplus` Parser n =
197 Parser $ \pos s -> case m pos s of
198 success@(Success _ _ _ _) -> success
199 Failure _ _ -> n pos s
201 getPos :: Parser SourcePos
202 getPos = Parser $ \pos s -> Success pos [] s pos
204 setPos :: SourcePos -> Parser ()
205 setPos pos = Parser $ \_ s -> Success pos [] s ()
207 message :: Parser a -> String -> Parser a
208 Parser m `message` msg =
209 Parser $ \pos s -> case m pos s of
210 success@(Success _ _ _ _) -> success
211 Failure pos' _ -> Failure pos' msg
213 catchOutput_ :: Parser a -> Parser String
214 catchOutput_ (Parser m) =
215 Parser $ \pos s -> case m pos s of
216 Success pos' out s' _ -> Success pos' [] s' out
217 Failure pos' msg -> Failure pos' msg
219 fakeOutput :: Parser a -> String -> Parser a
220 Parser m `fakeOutput` out =
221 Parser $ \pos s -> case m pos s of
222 Success pos' _ s' a -> Success pos' out s' a
223 Failure pos' msg -> Failure pos' msg
225 lookAhead :: Parser String
226 lookAhead = Parser $ \pos s -> Success pos [] s s
228 satisfy :: (Char -> Bool) -> Parser Char
230 Parser $ \pos s -> case s of
231 c:cs | p c -> Success (updatePos pos c) [c] cs c
232 _ -> Failure pos "Bad character"
234 char_ :: Char -> Parser ()
236 satisfy (== c) `message` (show c++" expected")
239 anyChar_ :: Parser ()
241 satisfy (const True) `message` "Unexpected end of file"
244 any2Chars_ :: Parser ()
245 any2Chars_ = anyChar_ >> anyChar_
247 many :: Parser a -> Parser [a]
248 many p = many1 p `mplus` return []
250 many1 :: Parser a -> Parser [a]
251 many1 p = liftM2 (:) p (many p)
253 many_ :: Parser a -> Parser ()
254 many_ p = many1_ p `mplus` return ()
256 many1_ :: Parser a -> Parser ()
257 many1_ p = p >> many_ p
259 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
260 manySatisfy = many . satisfy
261 manySatisfy1 = many1 . satisfy
263 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
264 manySatisfy_ = many_ . satisfy
265 manySatisfy1_ = many1_ . satisfy
267 ------------------------------------------------------------------------
268 -- Parser of hsc syntax.
271 = Text SourcePos String
272 | Special SourcePos String String
274 parser :: Parser [Token]
277 t <- catchOutput_ text
281 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
282 return (if null t then rest else Text pos t : rest)
289 c:_ | isAlpha c || c == '_' -> do
291 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
293 c:_ | isHsSymbol c -> do
294 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
297 '-':'-':symb' | all (== '-') symb' -> do
298 return () `fakeOutput` symb
299 manySatisfy_ (/= '\n')
302 return () `fakeOutput` unescapeHashes symb
304 '\"':_ -> do anyChar_; hsString '\"'; text
305 '\'':_ -> do anyChar_; hsString '\''; text
306 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
307 _:_ -> do anyChar_; text
309 hsString :: Char -> Parser ()
314 c:_ | c == quote -> anyChar_
319 char_ '\\' `mplus` return ()
321 | otherwise -> do any2Chars_; hsString quote
322 _:_ -> do anyChar_; hsString quote
324 hsComment :: Parser ()
329 '-':'}':_ -> any2Chars_
330 '{':'-':_ -> do any2Chars_; hsComment; hsComment
331 _:_ -> do anyChar_; hsComment
333 linePragma :: Parser ()
337 satisfy (\c -> c == 'L' || c == 'l')
338 satisfy (\c -> c == 'I' || c == 'i')
339 satisfy (\c -> c == 'N' || c == 'n')
340 satisfy (\c -> c == 'E' || c == 'e')
341 manySatisfy1_ isSpace
342 line <- liftM read $ manySatisfy1 isDigit
343 manySatisfy1_ isSpace
345 name <- manySatisfy (/= '\"')
351 setPos (SourcePos name (line - 1))
353 isHsSymbol :: Char -> Bool
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; isHsSymbol '@' = True; isHsSymbol '\\' = True
359 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
360 isHsSymbol '~' = True
363 unescapeHashes :: String -> String
364 unescapeHashes [] = []
365 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
366 unescapeHashes (c:s) = c : unescapeHashes s
368 lookAheadC :: Parser String
369 lookAheadC = liftM joinLines lookAhead
372 joinLines ('\\':'\n':s) = joinLines s
373 joinLines (c:s) = c : joinLines s
375 satisfyC :: (Char -> Bool) -> Parser Char
379 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
382 charC_ :: Char -> Parser ()
384 satisfyC (== c) `message` (show c++" expected")
387 anyCharC_ :: Parser ()
389 satisfyC (const True) `message` "Unexpected end of file"
392 any2CharsC_ :: Parser ()
393 any2CharsC_ = anyCharC_ >> anyCharC_
395 manySatisfyC :: (Char -> Bool) -> Parser String
396 manySatisfyC = many . satisfyC
398 manySatisfyC_ :: (Char -> Bool) -> Parser ()
399 manySatisfyC_ = many_ . satisfyC
401 special :: Parser Token
403 manySatisfyC_ (\c -> isSpace c && c /= '\n')
408 manySatisfyC_ isSpace
409 sp <- keyArg (== '\n')
412 _ -> keyArg (const False)
414 keyArg :: (Char -> Bool) -> Parser Token
417 key <- keyword `message` "hsc keyword or '{' expected"
418 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
419 arg <- catchOutput_ (argument eol)
420 return (Special pos key arg)
422 keyword :: Parser String
424 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
425 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
428 argument :: (Char -> Bool) -> Parser ()
433 c:_ | eol c -> do anyCharC_; argument eol
435 '\"':_ -> do anyCharC_; cString '\"'; argument eol
436 '\'':_ -> do anyCharC_; cString '\''; argument eol
437 '(':_ -> do anyCharC_; nested ')'; argument eol
439 '/':'*':_ -> do any2CharsC_; cComment; argument eol
441 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
442 '[':_ -> do anyCharC_; nested ']'; argument eol
444 '{':_ -> do anyCharC_; nested '}'; argument eol
446 _:_ -> do anyCharC_; argument eol
448 nested :: Char -> Parser ()
449 nested c = do argument (== '\n'); charC_ c
451 cComment :: Parser ()
456 '*':'/':_ -> do any2CharsC_
457 _:_ -> do anyCharC_; cComment
459 cString :: Char -> Parser ()
464 c:_ | c == quote -> anyCharC_
465 '\\':_:_ -> do any2CharsC_; cString quote
466 _:_ -> do anyCharC_; cString quote
468 ------------------------------------------------------------------------
469 -- Write the output files.
471 splitName :: String -> (String, String)
473 case break (== '/') name of
474 (file, []) -> ([], file)
475 (dir, sep:rest) -> (dir++sep:restDir, restFile)
477 (restDir, restFile) = splitName rest
479 splitExt :: String -> (String, String)
481 case break (== '.') name of
482 (base, []) -> (base, [])
483 (base, sepRest@(sep:rest))
484 | null restExt -> (base, sepRest)
485 | otherwise -> (base++sep:restBase, restExt)
487 (restBase, restExt) = splitExt rest
489 output :: [Flag] -> String -> [Token] -> IO ()
490 output flags name toks = do
492 (outName, outDir, outBase) <- case [f | Output f <- flags] of
493 [] -> if not (null ext) && last ext == 'c'
494 then return (dir++base++init ext, dir, base)
497 then return (dir++base++"_out.hs", dir, base)
498 else return (dir++base++".hs", dir, base)
500 (dir, file) = splitName name
501 (base, ext) = splitExt file
503 (dir, file) = splitName f
504 (base, _) = splitExt file
505 in return (f, dir, base)
506 _ -> onlyOne "output file"
508 let cProgName = outDir++outBase++"_hsc_make.c"
509 oProgName = outDir++outBase++"_hsc_make.o"
510 progName = outDir++outBase++"_hsc_make"
511 #if defined(mingw32_HOST_OS)
512 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
513 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
516 outHFile = outBase++"_hsc.h"
517 outHName = outDir++outHFile
518 outCName = outDir++outBase++"_hsc.c"
520 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
523 | null outDir = dosifyPath ("./" ++ progName)
524 | otherwise = progName
526 let specials = [(pos, key, arg) | Special pos key arg <- toks]
528 let needsC = any (\(_, key, _) -> key == "def") specials
531 let includeGuard = map fixChar outHName
533 fixChar c | isAlphaNum c = toUpper c
537 compiler <- case [c | Compiler c <- flags] of
540 _ -> onlyOne "compiler"
542 linker <- case [l | Linker l <- flags] of
543 [] -> return compiler
545 _ -> onlyOne "linker"
547 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
548 -- Returns a native-format path
550 mb <- getExecDir "bin/hsc2hs.exe"
552 Nothing -> return def
554 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
555 flg <- doesFileExist ghc_path
560 -- On a Win32 installation we execute the hsc2hs binary directly,
561 -- with no --cc flags, so we'll call locateGhc here, which will
562 -- succeed, via getExecDir.
564 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
565 -- (called plain hsc2hs in the installed tree), which will pass
566 -- a suitable C compiler via --cc
568 -- The in-place installation always uses the wrapper script,
569 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
570 compiler <- case [c | Compiler c <- flags] of
571 [] -> locateGhc "ghc"
573 _ -> onlyOne "compiler"
575 linker <- case [l | Linker l <- flags] of
576 [] -> locateGhc compiler
578 _ -> onlyOne "linker"
581 writeFile cProgName $
582 concatMap outFlagHeaderCProg flags++
583 concatMap outHeaderCProg specials++
584 "\nint main (int argc, char *argv [])\n{\n"++
585 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
586 outHsLine (SourcePos name 0)++
587 concatMap outTokenHs toks++
590 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
591 -- so we use something slightly more complicated. :-P
592 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
597 compilerStatus <- rawSystemL beVerbose compiler
599 ++ [f | CompFlag f <- flags]
604 case compilerStatus of
605 e@(ExitFailure _) -> exitWith e
609 linkerStatus <- rawSystemL beVerbose linker
610 ( [f | LinkFlag f <- flags]
616 e@(ExitFailure _) -> exitWith e
620 progStatus <- systemL beVerbose (execProgName++" >"++outName)
623 e@(ExitFailure _) -> exitWith e
626 when needsH $ writeFile outHName $
627 "#ifndef "++includeGuard++"\n" ++
628 "#define "++includeGuard++"\n" ++
629 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
630 "#include <Rts.h>\n" ++
632 "#include <HsFFI.h>\n" ++
635 "#define HsChar int\n" ++
637 concatMap outFlagH flags++
638 concatMap outTokenH specials++
641 when needsC $ writeFile outCName $
642 "#include \""++outHFile++"\"\n"++
643 concatMap outTokenC specials
644 -- NB. outHFile not outHName; works better when processed
645 -- by gcc or mkdependC.
647 rawSystemL :: Bool -> String -> [String] -> IO ExitCode
648 rawSystemL flg prog args = do
649 when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
652 systemL :: Bool -> String -> IO ExitCode
654 when flg (hPutStrLn stderr ("Executing: " ++ s))
657 onlyOne :: String -> IO a
658 onlyOne what = die ("Only one "++what++" may be specified\n")
660 outFlagHeaderCProg :: Flag -> String
661 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
662 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
663 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
664 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
665 outFlagHeaderCProg _ = ""
667 outHeaderCProg :: (SourcePos, String, String) -> String
668 outHeaderCProg (pos, key, arg) = case key of
669 "include" -> outCLine pos++"#include "++arg++"\n"
670 "define" -> outCLine pos++"#define "++arg++"\n"
671 "undef" -> outCLine pos++"#undef "++arg++"\n"
673 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
674 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
676 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
677 "let" -> case break (== '=') arg of
679 (header, _:body) -> case break isSpace header of
682 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
683 "printf ("++joinLines body++");\n"
686 joinLines = concat . intersperse " \\\n" . lines
688 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
689 outHeaderHs flags inH toks =
691 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
692 " printf (\"{-# OPTIONS -optc-D" ++
693 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
694 "__GLASGOW_HASKELL__);\n" ++
697 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
698 Just f -> outOption ("-#include \""++f++"\"")
700 outFlag (Include f) = outOption ("-#include "++f)
701 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
702 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
704 outSpecial (pos, key, arg) = case key of
705 "include" -> outOption ("-#include "++arg)
706 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
708 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
710 goodForOptD arg = case arg of
712 c:_ | isSpace c -> True
715 toOptD arg = case break isSpace arg of
717 (name, _:value) -> name++'=':dropWhile isSpace value
718 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
719 showCString s++"\");\n"
721 outTokenHs :: Token -> String
722 outTokenHs (Text pos txt) =
723 case break (== '\n') txt of
724 (allTxt, []) -> outText allTxt
726 outText (first++"\n")++
730 outText s = " fputs (\""++showCString s++"\", stdout);\n"
731 outTokenHs (Special pos key arg) =
737 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
739 "enum" -> outCLine pos++outEnum arg
740 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
742 outEnum :: String -> String
744 case break (== ',') arg of
746 (t, _:afterT) -> case break (== ',') afterT of
749 enums (_:s) = case break (== ',') s of
751 this = case break (== '=') $ dropWhile isSpace enum of
753 " hsc_enum ("++t++", "++f++", " ++
754 "hsc_haskellize (\""++name++"\"), "++
757 " hsc_enum ("++t++", "++f++", " ++
758 "printf (\"%s\", \""++hsName++"\"), "++
763 outFlagH :: Flag -> String
764 outFlagH (Include f) = "#include "++f++"\n"
765 outFlagH (Define n Nothing) = "#define "++n++"\n"
766 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
769 outTokenH :: (SourcePos, String, String) -> String
770 outTokenH (pos, key, arg) =
772 "include" -> outCLine pos++"#include "++arg++"\n"
773 "define" -> outCLine pos++"#define " ++arg++"\n"
774 "undef" -> outCLine pos++"#undef " ++arg++"\n"
775 "def" -> outCLine pos++case arg of
776 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
777 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
778 'i':'n':'l':'i':'n':'e':' ':_ ->
779 "#ifdef __GNUC__\n" ++
783 _ -> "extern "++header++";\n"
784 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
785 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
788 outTokenC :: (SourcePos, String, String) -> String
789 outTokenC (pos, key, arg) =
792 's':'t':'r':'u':'c':'t':' ':_ -> ""
793 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
794 'i':'n':'l':'i':'n':'e':' ':arg' ->
795 case span (\c -> c /= '{' && c /= '=') arg' of
798 "#ifndef __GNUC__\n" ++
802 "\n#ifndef __GNUC__\n" ++
807 _ -> outCLine pos++arg++"\n"
808 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
811 conditional :: String -> Bool
812 conditional "if" = True
813 conditional "ifdef" = True
814 conditional "ifndef" = True
815 conditional "elif" = True
816 conditional "else" = True
817 conditional "endif" = True
818 conditional "error" = True
819 conditional "warning" = True
820 conditional _ = False
822 outCLine :: SourcePos -> String
823 outCLine (SourcePos name line) =
824 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
826 outHsLine :: SourcePos -> String
827 outHsLine (SourcePos name line) =
828 " hsc_line ("++show (line + 1)++", \""++
829 showCString (snd (splitName name))++"\");\n"
831 showCString :: String -> String
832 showCString = concatMap showCChar
834 showCChar '\"' = "\\\""
835 showCChar '\'' = "\\\'"
836 showCChar '?' = "\\?"
837 showCChar '\\' = "\\\\"
838 showCChar c | c >= ' ' && c <= '~' = [c]
839 showCChar '\a' = "\\a"
840 showCChar '\b' = "\\b"
841 showCChar '\f' = "\\f"
842 showCChar '\n' = "\\n\"\n \""
843 showCChar '\r' = "\\r"
844 showCChar '\t' = "\\t"
845 showCChar '\v' = "\\v"
847 intToDigit (ord c `quot` 64),
848 intToDigit (ord c `quot` 8 `mod` 8),
849 intToDigit (ord c `mod` 8)]
853 -----------------------------------------
854 -- Cut and pasted from ghc/compiler/SysTools
855 -- Convert paths foo/baz to foo\baz on Windows
857 dosifyPath, unDosifyPath :: String -> String
858 #if defined(mingw32_HOST_OS)
859 dosifyPath xs = subst '/' '\\' xs
860 unDosifyPath xs = subst '\\' '/' xs
862 subst :: Eq a => a -> a -> [a] -> [a]
863 subst a b ls = map (\ x -> if x == a then b else x) ls
869 getExecDir :: String -> IO (Maybe String)
870 -- (getExecDir cmd) returns the directory in which the current
871 -- executable, which should be called 'cmd', is running
872 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
873 -- you'll get "/a/b/c" back as the result
878 return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s)))))
879 #elif defined(mingw32_HOST_OS)
881 = allocaArray len $ \buf -> do
882 ret <- getModuleFileName nullPtr buf len
883 if ret == 0 then return Nothing
884 else do s <- peekCString buf
885 return (Just (reverse (drop (length cmd)
886 (reverse (unDosifyPath s)))))
888 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
890 foreign import stdcall unsafe "GetModuleFileNameA"
891 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
894 getExecDir _ = return Nothing