1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.66 2005/01/06 14:55:02 malcolm 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
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)
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 (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
120 do mb_path <- getExecDir "/bin/hsc2hs.exe"
125 let templ = path ++ "/template-hsc.h"
126 flg <- doesFileExist templ
128 then return ((Template templ):)
130 return (add_opt flags)
131 case (files, errs) of
133 | any isHelp flags_w_tpl -> bye (usageInfo header options)
134 | any isVersion flags_w_tpl -> bye version
136 isHelp Help = True; isHelp _ = False
137 isVersion Version = True; isVersion _ = False
138 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
139 (_, _ ) -> die (concat errs ++ usageInfo header options)
141 getProgramName :: IO String
142 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
143 where str `withoutSuffix` suff
144 | suff `isSuffixOf` str = take (length str - length suff) str
147 bye :: String -> IO a
148 bye s = putStr s >> exitWith ExitSuccess
150 die :: String -> IO a
151 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
153 processFile :: [Flag] -> String -> IO ()
154 processFile flags name
155 = do let file_name = dosifyPath name
156 s <- readFile file_name
158 Parser p -> case p (SourcePos file_name 1) s of
159 Success _ _ _ toks -> output flags file_name toks
160 Failure (SourcePos name' line) msg ->
161 die (name'++":"++show line++": "++msg++"\n")
163 ------------------------------------------------------------------------
164 -- A deterministic parser which remembers the text which has been parsed.
166 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
168 data ParseResult a = Success !SourcePos String String a
169 | Failure !SourcePos String
171 data SourcePos = SourcePos String !Int
173 updatePos :: SourcePos -> Char -> SourcePos
174 updatePos pos@(SourcePos name line) ch = case ch of
175 '\n' -> SourcePos name (line + 1)
178 instance Monad Parser where
179 return a = Parser $ \pos s -> Success pos [] s a
181 Parser $ \pos s -> case m pos s of
182 Success pos' out1 s' a -> case k a of
183 Parser k' -> case k' pos' s' of
184 Success pos'' out2 imp'' b ->
185 Success pos'' (out1++out2) imp'' b
186 Failure pos'' msg -> Failure pos'' msg
187 Failure pos' msg -> Failure pos' msg
188 fail msg = Parser $ \pos _ -> Failure pos msg
190 instance MonadPlus Parser where
192 Parser m `mplus` Parser n =
193 Parser $ \pos s -> case m pos s of
194 success@(Success _ _ _ _) -> success
195 Failure _ _ -> n pos s
197 getPos :: Parser SourcePos
198 getPos = Parser $ \pos s -> Success pos [] s pos
200 setPos :: SourcePos -> Parser ()
201 setPos pos = Parser $ \_ s -> Success pos [] s ()
203 message :: Parser a -> String -> Parser a
204 Parser m `message` msg =
205 Parser $ \pos s -> case m pos s of
206 success@(Success _ _ _ _) -> success
207 Failure pos' _ -> Failure pos' msg
209 catchOutput_ :: Parser a -> Parser String
210 catchOutput_ (Parser m) =
211 Parser $ \pos s -> case m pos s of
212 Success pos' out s' _ -> Success pos' [] s' out
213 Failure pos' msg -> Failure pos' msg
215 fakeOutput :: Parser a -> String -> Parser a
216 Parser m `fakeOutput` out =
217 Parser $ \pos s -> case m pos s of
218 Success pos' _ s' a -> Success pos' out s' a
219 Failure pos' msg -> Failure pos' msg
221 lookAhead :: Parser String
222 lookAhead = Parser $ \pos s -> Success pos [] s s
224 satisfy :: (Char -> Bool) -> Parser Char
226 Parser $ \pos s -> case s of
227 c:cs | p c -> Success (updatePos pos c) [c] cs c
228 _ -> Failure pos "Bad character"
230 char_ :: Char -> Parser ()
232 satisfy (== c) `message` (show c++" expected")
235 anyChar_ :: Parser ()
237 satisfy (const True) `message` "Unexpected end of file"
240 any2Chars_ :: Parser ()
241 any2Chars_ = anyChar_ >> anyChar_
243 many :: Parser a -> Parser [a]
244 many p = many1 p `mplus` return []
246 many1 :: Parser a -> Parser [a]
247 many1 p = liftM2 (:) p (many p)
249 many_ :: Parser a -> Parser ()
250 many_ p = many1_ p `mplus` return ()
252 many1_ :: Parser a -> Parser ()
253 many1_ p = p >> many_ p
255 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
256 manySatisfy = many . satisfy
257 manySatisfy1 = many1 . satisfy
259 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
260 manySatisfy_ = many_ . satisfy
261 manySatisfy1_ = many1_ . satisfy
263 ------------------------------------------------------------------------
264 -- Parser of hsc syntax.
267 = Text SourcePos String
268 | Special SourcePos String String
270 parser :: Parser [Token]
273 t <- catchOutput_ text
277 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
278 return (if null t then rest else Text pos t : rest)
285 c:_ | isAlpha c || c == '_' -> do
287 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
289 c:_ | isHsSymbol c -> do
290 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
293 '-':'-':symb' | all (== '-') symb' -> do
294 return () `fakeOutput` symb
295 manySatisfy_ (/= '\n')
298 return () `fakeOutput` unescapeHashes symb
300 '\"':_ -> do anyChar_; hsString '\"'; text
301 '\'':_ -> do anyChar_; hsString '\''; text
302 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
303 _:_ -> do anyChar_; text
305 hsString :: Char -> Parser ()
310 c:_ | c == quote -> anyChar_
315 char_ '\\' `mplus` return ()
317 | otherwise -> do any2Chars_; hsString quote
318 _:_ -> do anyChar_; hsString quote
320 hsComment :: Parser ()
325 '-':'}':_ -> any2Chars_
326 '{':'-':_ -> do any2Chars_; hsComment; hsComment
327 _:_ -> do anyChar_; hsComment
329 linePragma :: Parser ()
333 satisfy (\c -> c == 'L' || c == 'l')
334 satisfy (\c -> c == 'I' || c == 'i')
335 satisfy (\c -> c == 'N' || c == 'n')
336 satisfy (\c -> c == 'E' || c == 'e')
337 manySatisfy1_ isSpace
338 line <- liftM read $ manySatisfy1 isDigit
339 manySatisfy1_ isSpace
341 name <- manySatisfy (/= '\"')
347 setPos (SourcePos name (line - 1))
349 isHsSymbol :: Char -> Bool
350 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
351 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
352 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
353 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
354 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
355 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
356 isHsSymbol '~' = True
359 unescapeHashes :: String -> String
360 unescapeHashes [] = []
361 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
362 unescapeHashes (c:s) = c : unescapeHashes s
364 lookAheadC :: Parser String
365 lookAheadC = liftM joinLines lookAhead
368 joinLines ('\\':'\n':s) = joinLines s
369 joinLines (c:s) = c : joinLines s
371 satisfyC :: (Char -> Bool) -> Parser Char
375 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
378 charC_ :: Char -> Parser ()
380 satisfyC (== c) `message` (show c++" expected")
383 anyCharC_ :: Parser ()
385 satisfyC (const True) `message` "Unexpected end of file"
388 any2CharsC_ :: Parser ()
389 any2CharsC_ = anyCharC_ >> anyCharC_
391 manySatisfyC :: (Char -> Bool) -> Parser String
392 manySatisfyC = many . satisfyC
394 manySatisfyC_ :: (Char -> Bool) -> Parser ()
395 manySatisfyC_ = many_ . satisfyC
397 special :: Parser Token
399 manySatisfyC_ (\c -> isSpace c && c /= '\n')
404 manySatisfyC_ isSpace
405 sp <- keyArg (== '\n')
408 _ -> keyArg (const False)
410 keyArg :: (Char -> Bool) -> Parser Token
413 key <- keyword `message` "hsc keyword or '{' expected"
414 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
415 arg <- catchOutput_ (argument eol)
416 return (Special pos key arg)
418 keyword :: Parser String
420 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
421 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
424 argument :: (Char -> Bool) -> Parser ()
429 c:_ | eol c -> do anyCharC_; argument eol
431 '\"':_ -> do anyCharC_; cString '\"'; argument eol
432 '\'':_ -> do anyCharC_; cString '\''; argument eol
433 '(':_ -> do anyCharC_; nested ')'; argument eol
435 '/':'*':_ -> do any2CharsC_; cComment; argument eol
437 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
438 '[':_ -> do anyCharC_; nested ']'; argument eol
440 '{':_ -> do anyCharC_; nested '}'; argument eol
442 _:_ -> do anyCharC_; argument eol
444 nested :: Char -> Parser ()
445 nested c = do argument (== '\n'); charC_ c
447 cComment :: Parser ()
452 '*':'/':_ -> do any2CharsC_
453 _:_ -> do anyCharC_; cComment
455 cString :: Char -> Parser ()
460 c:_ | c == quote -> anyCharC_
461 '\\':_:_ -> do any2CharsC_; cString quote
462 _:_ -> do anyCharC_; cString quote
464 ------------------------------------------------------------------------
465 -- Write the output files.
467 splitName :: String -> (String, String)
469 case break (== '/') name of
470 (file, []) -> ([], file)
471 (dir, sep:rest) -> (dir++sep:restDir, restFile)
473 (restDir, restFile) = splitName rest
475 splitExt :: String -> (String, String)
477 case break (== '.') name of
478 (base, []) -> (base, [])
479 (base, sepRest@(sep:rest))
480 | null restExt -> (base, sepRest)
481 | otherwise -> (base++sep:restBase, restExt)
483 (restBase, restExt) = splitExt rest
485 output :: [Flag] -> String -> [Token] -> IO ()
486 output flags name toks = do
488 (outName, outDir, outBase) <- case [f | Output f <- flags] of
489 [] -> if not (null ext) && last ext == 'c'
490 then return (dir++base++init ext, dir, base)
493 then return (dir++base++"_out.hs", dir, base)
494 else return (dir++base++".hs", dir, base)
496 (dir, file) = splitName name
497 (base, ext) = splitExt file
499 (dir, file) = splitName f
500 (base, _) = splitExt file
501 in return (f, dir, base)
502 _ -> onlyOne "output file"
504 let cProgName = outDir++outBase++"_hsc_make.c"
505 oProgName = outDir++outBase++"_hsc_make.o"
506 progName = outDir++outBase++"_hsc_make"
507 #if defined(mingw32_HOST_OS)
508 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
509 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
512 outHFile = outBase++"_hsc.h"
513 outHName = outDir++outHFile
514 outCName = outDir++outBase++"_hsc.c"
516 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
519 | null outDir = dosifyPath ("./" ++ progName)
520 | otherwise = progName
522 let specials = [(pos, key, arg) | Special pos key arg <- toks]
524 let needsC = any (\(_, key, _) -> key == "def") specials
527 let includeGuard = map fixChar outHName
529 fixChar c | isAlphaNum c = toUpper c
532 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
533 -- Returns a native-format path
535 mb <- getExecDir "bin/hsc2hs.exe"
537 Nothing -> return def
539 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
540 flg <- doesFileExist ghc_path
545 -- On a Win32 installation we execute the hsc2hs binary directly,
546 -- with no --cc flags, so we'll call locateGhc here, which will
547 -- succeed, via getExecDir.
549 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
550 -- (called plain hsc2hs in the installed tree), which will pass
551 -- a suitable C compiler via --cc
553 -- The in-place installation always uses the wrapper script,
554 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
555 compiler <- case [c | Compiler c <- flags] of
556 [] -> locateGhc "ghc"
558 _ -> onlyOne "compiler"
560 linker <- case [l | Linker l <- flags] of
561 [] -> locateGhc compiler
563 _ -> onlyOne "linker"
565 writeFile cProgName $
566 concatMap outFlagHeaderCProg flags++
567 concatMap outHeaderCProg specials++
568 "\nint main (int argc, char *argv [])\n{\n"++
569 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
570 outHsLine (SourcePos name 0)++
571 concatMap outTokenHs toks++
574 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
575 -- so we use something slightly more complicated. :-P
576 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
581 compilerStatus <- rawSystemL beVerbose compiler
583 ++ [f | CompFlag f <- flags]
588 case compilerStatus of
589 e@(ExitFailure _) -> exitWith e
593 linkerStatus <- rawSystemL beVerbose linker
594 ( [f | LinkFlag f <- flags]
600 e@(ExitFailure _) -> exitWith e
604 progStatus <- systemL beVerbose (execProgName++" >"++outName)
607 e@(ExitFailure _) -> exitWith e
610 when needsH $ writeFile outHName $
611 "#ifndef "++includeGuard++"\n" ++
612 "#define "++includeGuard++"\n" ++
613 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
614 "#include <Rts.h>\n" ++
616 "#include <HsFFI.h>\n" ++
619 "#define HsChar int\n" ++
621 concatMap outFlagH flags++
622 concatMap outTokenH specials++
625 when needsC $ writeFile outCName $
626 "#include \""++outHFile++"\"\n"++
627 concatMap outTokenC specials
628 -- NB. outHFile not outHName; works better when processed
629 -- by gcc or mkdependC.
631 rawSystemL :: Bool -> String -> [String] -> IO ExitCode
632 rawSystemL flg prog args = do
633 when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
636 systemL :: Bool -> String -> IO ExitCode
638 when flg (hPutStrLn stderr ("Executing: " ++ s))
641 onlyOne :: String -> IO a
642 onlyOne what = die ("Only one "++what++" may be specified\n")
644 outFlagHeaderCProg :: Flag -> String
645 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
646 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
647 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
648 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
649 outFlagHeaderCProg _ = ""
651 outHeaderCProg :: (SourcePos, String, String) -> String
652 outHeaderCProg (pos, key, arg) = case key of
653 "include" -> outCLine pos++"#include "++arg++"\n"
654 "define" -> outCLine pos++"#define "++arg++"\n"
655 "undef" -> outCLine pos++"#undef "++arg++"\n"
657 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
658 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
660 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
661 "let" -> case break (== '=') arg of
663 (header, _:body) -> case break isSpace header of
666 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
667 "printf ("++joinLines body++");\n"
670 joinLines = concat . intersperse " \\\n" . lines
672 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
673 outHeaderHs flags inH toks =
675 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
676 " printf (\"{-# OPTIONS -optc-D" ++
677 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
678 "__GLASGOW_HASKELL__);\n" ++
681 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
682 Just f -> outOption ("-#include \""++f++"\"")
684 outFlag (Include f) = outOption ("-#include "++f)
685 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
686 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
688 outSpecial (pos, key, arg) = case key of
689 "include" -> outOption ("-#include "++arg)
690 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
692 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
694 goodForOptD arg = case arg of
696 c:_ | isSpace c -> True
699 toOptD arg = case break isSpace arg of
701 (name, _:value) -> name++'=':dropWhile isSpace value
702 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
703 showCString s++"\");\n"
705 outTokenHs :: Token -> String
706 outTokenHs (Text pos txt) =
707 case break (== '\n') txt of
708 (allTxt, []) -> outText allTxt
710 outText (first++"\n")++
714 outText s = " fputs (\""++showCString s++"\", stdout);\n"
715 outTokenHs (Special pos key arg) =
721 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
723 "enum" -> outCLine pos++outEnum arg
724 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
726 outEnum :: String -> String
728 case break (== ',') arg of
730 (t, _:afterT) -> case break (== ',') afterT of
733 enums (_:s) = case break (== ',') s of
735 this = case break (== '=') $ dropWhile isSpace enum of
737 " hsc_enum ("++t++", "++f++", " ++
738 "hsc_haskellize (\""++name++"\"), "++
741 " hsc_enum ("++t++", "++f++", " ++
742 "printf (\"%s\", \""++hsName++"\"), "++
747 outFlagH :: Flag -> String
748 outFlagH (Include f) = "#include "++f++"\n"
749 outFlagH (Define n Nothing) = "#define "++n++"\n"
750 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
753 outTokenH :: (SourcePos, String, String) -> String
754 outTokenH (pos, key, arg) =
756 "include" -> outCLine pos++"#include "++arg++"\n"
757 "define" -> outCLine pos++"#define " ++arg++"\n"
758 "undef" -> outCLine pos++"#undef " ++arg++"\n"
759 "def" -> outCLine pos++case arg of
760 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
761 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
762 'i':'n':'l':'i':'n':'e':' ':_ ->
763 "#ifdef __GNUC__\n" ++
767 _ -> "extern "++header++";\n"
768 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
769 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
772 outTokenC :: (SourcePos, String, String) -> String
773 outTokenC (pos, key, arg) =
776 's':'t':'r':'u':'c':'t':' ':_ -> ""
777 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
778 'i':'n':'l':'i':'n':'e':' ':arg' ->
779 case span (\c -> c /= '{' && c /= '=') arg' of
782 "#ifndef __GNUC__\n" ++
786 "\n#ifndef __GNUC__\n" ++
791 _ -> outCLine pos++arg++"\n"
792 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
795 conditional :: String -> Bool
796 conditional "if" = True
797 conditional "ifdef" = True
798 conditional "ifndef" = True
799 conditional "elif" = True
800 conditional "else" = True
801 conditional "endif" = True
802 conditional "error" = True
803 conditional "warning" = True
804 conditional _ = False
806 outCLine :: SourcePos -> String
807 outCLine (SourcePos name line) =
808 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
810 outHsLine :: SourcePos -> String
811 outHsLine (SourcePos name line) =
812 " hsc_line ("++show (line + 1)++", \""++
813 showCString (snd (splitName name))++"\");\n"
815 showCString :: String -> String
816 showCString = concatMap showCChar
818 showCChar '\"' = "\\\""
819 showCChar '\'' = "\\\'"
820 showCChar '?' = "\\?"
821 showCChar '\\' = "\\\\"
822 showCChar c | c >= ' ' && c <= '~' = [c]
823 showCChar '\a' = "\\a"
824 showCChar '\b' = "\\b"
825 showCChar '\f' = "\\f"
826 showCChar '\n' = "\\n\"\n \""
827 showCChar '\r' = "\\r"
828 showCChar '\t' = "\\t"
829 showCChar '\v' = "\\v"
831 intToDigit (ord c `quot` 64),
832 intToDigit (ord c `quot` 8 `mod` 8),
833 intToDigit (ord c `mod` 8)]
837 -----------------------------------------
838 -- Cut and pasted from ghc/compiler/SysTools
839 -- Convert paths foo/baz to foo\baz on Windows
841 dosifyPath :: String -> String
842 #if defined(mingw32_HOST_OS)
843 dosifyPath xs = subst '/' '\\' xs
845 unDosifyPath :: String -> String
846 unDosifyPath xs = subst '\\' '/' xs
848 subst :: Eq a => a -> a -> [a] -> [a]
849 subst a b ls = map (\ x -> if x == a then b else x) ls
851 getExecDir :: String -> IO (Maybe String)
852 -- (getExecDir cmd) returns the directory in which the current
853 -- executable, which should be called 'cmd', is running
854 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
855 -- you'll get "/a/b/c" back as the result
857 = allocaArray len $ \buf -> do
858 ret <- getModuleFileName nullPtr buf len
859 if ret == 0 then return Nothing
860 else do s <- peekCString buf
861 return (Just (reverse (drop (length cmd)
862 (reverse (unDosifyPath s)))))
864 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
866 foreign import stdcall unsafe "GetModuleFileNameA"
867 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
872 getExecDir :: String -> IO (Maybe String)
873 getExecDir _ = return Nothing