1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.61 2005/01/05 10:26:45 simonmar 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 Compat.RawSystem ( rawSystem )
22 import System (getProgName, getArgs, ExitCode(..), exitWith, system)
23 import Directory (removeFile,doesFileExist)
24 import Monad (MonadPlus(..), liftM, liftM2, when)
25 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
26 import List (intersperse, isSuffixOf)
27 import IO (hPutStr, hPutStrLn, stderr)
29 #if defined(mingw32_HOST_OS)
31 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
32 import Foreign.C.String
40 version = "hsc2hs version 0.66\n"
52 | Define String (Maybe String)
56 template_flag :: Flag -> Bool
57 template_flag (Template _) = True
58 template_flag _ = False
60 include :: String -> Flag
61 include s@('\"':_) = Include s
62 include s@('<' :_) = Include s
63 include s = Include ("\""++s++"\"")
65 define :: String -> Flag
66 define s = case break (== '=') s of
67 (name, []) -> Define name Nothing
68 (name, _:value) -> Define name (Just value)
70 options :: [OptDescr Flag]
72 Option ['o'] ["output"] (ReqArg Output "FILE")
73 "name of main output file",
74 Option ['t'] ["template"] (ReqArg Template "FILE")
76 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
78 Option ['l'] ["ld"] (ReqArg Linker "PROG")
80 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
81 "flag to pass to the C compiler",
82 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
83 "passed to the C compiler",
84 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
85 "flag to pass to the linker",
86 Option ['i'] ["include"] (ReqArg include "FILE")
87 "as if placed in the source",
88 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
89 "as if placed in the source",
90 Option [] ["no-compile"] (NoArg NoCompile)
91 "stop after writing *_hsc_make.c",
92 Option ['v'] ["verbose"] (NoArg Verbose)
93 "dump commands to stderr",
94 Option ['?'] ["help"] (NoArg Help)
95 "display this help and exit",
96 Option ['V'] ["version"] (NoArg Version)
97 "output version information and exit" ]
102 prog <- getProgramName
103 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
105 let (flags, files, errs) = getOpt Permute options args
107 -- If there is no Template flag explicitly specified, try
108 -- to find one by looking near the executable. This only
109 -- works on Win32 (getExecDir). On Unix, there's a wrapper
110 -- script which specifies an explicit template flag.
111 flags_w_tpl <- if any template_flag flags then
114 do mb_path <- getExecDir "/bin/hsc2hs.exe"
119 let templ = path ++ "/template-hsc.h"
120 flg <- doesFileExist templ
122 then return ((Template templ):)
124 return (add_opt flags)
125 case (files, errs) of
127 | any isHelp flags_w_tpl -> bye (usageInfo header options)
128 | any isVersion flags_w_tpl -> bye version
130 isHelp Help = True; isHelp _ = False
131 isVersion Version = True; isVersion _ = False
132 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
133 (_, _ ) -> die (concat errs ++ usageInfo header options)
135 getProgramName :: IO String
136 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
137 where str `withoutSuffix` suff
138 | suff `isSuffixOf` str = take (length str - length suff) str
141 bye :: String -> IO a
142 bye s = putStr s >> exitWith ExitSuccess
144 die :: String -> IO a
145 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
147 processFile :: [Flag] -> String -> IO ()
148 processFile flags name
149 = do let file_name = dosifyPath name
150 s <- readFile file_name
152 Parser p -> case p (SourcePos file_name 1) s of
153 Success _ _ _ toks -> output flags file_name toks
154 Failure (SourcePos name' line) msg ->
155 die (name'++":"++show line++": "++msg++"\n")
157 ------------------------------------------------------------------------
158 -- A deterministic parser which remembers the text which has been parsed.
160 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
162 data ParseResult a = Success !SourcePos String String a
163 | Failure !SourcePos String
165 data SourcePos = SourcePos String !Int
167 updatePos :: SourcePos -> Char -> SourcePos
168 updatePos pos@(SourcePos name line) ch = case ch of
169 '\n' -> SourcePos name (line + 1)
172 instance Monad Parser where
173 return a = Parser $ \pos s -> Success pos [] s a
175 Parser $ \pos s -> case m pos s of
176 Success pos' out1 s' a -> case k a of
177 Parser k' -> case k' pos' s' of
178 Success pos'' out2 imp'' b ->
179 Success pos'' (out1++out2) imp'' b
180 Failure pos'' msg -> Failure pos'' msg
181 Failure pos' msg -> Failure pos' msg
182 fail msg = Parser $ \pos _ -> Failure pos msg
184 instance MonadPlus Parser where
186 Parser m `mplus` Parser n =
187 Parser $ \pos s -> case m pos s of
188 success@(Success _ _ _ _) -> success
189 Failure _ _ -> n pos s
191 getPos :: Parser SourcePos
192 getPos = Parser $ \pos s -> Success pos [] s pos
194 setPos :: SourcePos -> Parser ()
195 setPos pos = Parser $ \_ s -> Success pos [] s ()
197 message :: Parser a -> String -> Parser a
198 Parser m `message` msg =
199 Parser $ \pos s -> case m pos s of
200 success@(Success _ _ _ _) -> success
201 Failure pos' _ -> Failure pos' msg
203 catchOutput_ :: Parser a -> Parser String
204 catchOutput_ (Parser m) =
205 Parser $ \pos s -> case m pos s of
206 Success pos' out s' _ -> Success pos' [] s' out
207 Failure pos' msg -> Failure pos' msg
209 fakeOutput :: Parser a -> String -> Parser a
210 Parser m `fakeOutput` out =
211 Parser $ \pos s -> case m pos s of
212 Success pos' _ s' a -> Success pos' out s' a
213 Failure pos' msg -> Failure pos' msg
215 lookAhead :: Parser String
216 lookAhead = Parser $ \pos s -> Success pos [] s s
218 satisfy :: (Char -> Bool) -> Parser Char
220 Parser $ \pos s -> case s of
221 c:cs | p c -> Success (updatePos pos c) [c] cs c
222 _ -> Failure pos "Bad character"
224 char_ :: Char -> Parser ()
226 satisfy (== c) `message` (show c++" expected")
229 anyChar_ :: Parser ()
231 satisfy (const True) `message` "Unexpected end of file"
234 any2Chars_ :: Parser ()
235 any2Chars_ = anyChar_ >> anyChar_
237 many :: Parser a -> Parser [a]
238 many p = many1 p `mplus` return []
240 many1 :: Parser a -> Parser [a]
241 many1 p = liftM2 (:) p (many p)
243 many_ :: Parser a -> Parser ()
244 many_ p = many1_ p `mplus` return ()
246 many1_ :: Parser a -> Parser ()
247 many1_ p = p >> many_ p
249 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
250 manySatisfy = many . satisfy
251 manySatisfy1 = many1 . satisfy
253 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
254 manySatisfy_ = many_ . satisfy
255 manySatisfy1_ = many1_ . satisfy
257 ------------------------------------------------------------------------
258 -- Parser of hsc syntax.
261 = Text SourcePos String
262 | Special SourcePos String String
264 parser :: Parser [Token]
267 t <- catchOutput_ text
271 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
272 return (if null t then rest else Text pos t : rest)
279 c:_ | isAlpha c || c == '_' -> do
281 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
283 c:_ | isHsSymbol c -> do
284 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
287 '-':'-':symb' | all (== '-') symb' -> do
288 return () `fakeOutput` symb
289 manySatisfy_ (/= '\n')
292 return () `fakeOutput` unescapeHashes symb
294 '\"':_ -> do anyChar_; hsString '\"'; text
295 '\'':_ -> do anyChar_; hsString '\''; text
296 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
297 _:_ -> do anyChar_; text
299 hsString :: Char -> Parser ()
304 c:_ | c == quote -> anyChar_
309 char_ '\\' `mplus` return ()
311 | otherwise -> do any2Chars_; hsString quote
312 _:_ -> do anyChar_; hsString quote
314 hsComment :: Parser ()
319 '-':'}':_ -> any2Chars_
320 '{':'-':_ -> do any2Chars_; hsComment; hsComment
321 _:_ -> do anyChar_; hsComment
323 linePragma :: Parser ()
327 satisfy (\c -> c == 'L' || c == 'l')
328 satisfy (\c -> c == 'I' || c == 'i')
329 satisfy (\c -> c == 'N' || c == 'n')
330 satisfy (\c -> c == 'E' || c == 'e')
331 manySatisfy1_ isSpace
332 line <- liftM read $ manySatisfy1 isDigit
333 manySatisfy1_ isSpace
335 name <- manySatisfy (/= '\"')
341 setPos (SourcePos name (line - 1))
343 isHsSymbol :: Char -> Bool
344 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
345 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
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
353 unescapeHashes :: String -> String
354 unescapeHashes [] = []
355 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
356 unescapeHashes (c:s) = c : unescapeHashes s
358 lookAheadC :: Parser String
359 lookAheadC = liftM joinLines lookAhead
362 joinLines ('\\':'\n':s) = joinLines s
363 joinLines (c:s) = c : joinLines s
365 satisfyC :: (Char -> Bool) -> Parser Char
369 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
372 charC_ :: Char -> Parser ()
374 satisfyC (== c) `message` (show c++" expected")
377 anyCharC_ :: Parser ()
379 satisfyC (const True) `message` "Unexpected end of file"
382 any2CharsC_ :: Parser ()
383 any2CharsC_ = anyCharC_ >> anyCharC_
385 manySatisfyC :: (Char -> Bool) -> Parser String
386 manySatisfyC = many . satisfyC
388 manySatisfyC_ :: (Char -> Bool) -> Parser ()
389 manySatisfyC_ = many_ . satisfyC
391 special :: Parser Token
393 manySatisfyC_ (\c -> isSpace c && c /= '\n')
398 manySatisfyC_ isSpace
399 sp <- keyArg (== '\n')
402 _ -> keyArg (const False)
404 keyArg :: (Char -> Bool) -> Parser Token
407 key <- keyword `message` "hsc keyword or '{' expected"
408 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
409 arg <- catchOutput_ (argument eol)
410 return (Special pos key arg)
412 keyword :: Parser String
414 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
415 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
418 argument :: (Char -> Bool) -> Parser ()
423 c:_ | eol c -> do anyCharC_; argument eol
425 '\"':_ -> do anyCharC_; cString '\"'; argument eol
426 '\'':_ -> do anyCharC_; cString '\''; argument eol
427 '(':_ -> do anyCharC_; nested ')'; argument eol
429 '/':'*':_ -> do any2CharsC_; cComment; argument eol
431 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
432 '[':_ -> do anyCharC_; nested ']'; argument eol
434 '{':_ -> do anyCharC_; nested '}'; argument eol
436 _:_ -> do anyCharC_; argument eol
438 nested :: Char -> Parser ()
439 nested c = do argument (== '\n'); charC_ c
441 cComment :: Parser ()
446 '*':'/':_ -> do any2CharsC_
447 _:_ -> do anyCharC_; cComment
449 cString :: Char -> Parser ()
454 c:_ | c == quote -> anyCharC_
455 '\\':_:_ -> do any2CharsC_; cString quote
456 _:_ -> do anyCharC_; cString quote
458 ------------------------------------------------------------------------
459 -- Write the output files.
461 splitName :: String -> (String, String)
463 case break (== '/') name of
464 (file, []) -> ([], file)
465 (dir, sep:rest) -> (dir++sep:restDir, restFile)
467 (restDir, restFile) = splitName rest
469 splitExt :: String -> (String, String)
471 case break (== '.') name of
472 (base, []) -> (base, [])
473 (base, sepRest@(sep:rest))
474 | null restExt -> (base, sepRest)
475 | otherwise -> (base++sep:restBase, restExt)
477 (restBase, restExt) = splitExt rest
479 output :: [Flag] -> String -> [Token] -> IO ()
480 output flags name toks = do
482 (outName, outDir, outBase) <- case [f | Output f <- flags] of
483 [] -> if not (null ext) && last ext == 'c'
484 then return (dir++base++init ext, dir, base)
487 then return (dir++base++"_out.hs", dir, base)
488 else return (dir++base++".hs", dir, base)
490 (dir, file) = splitName name
491 (base, ext) = splitExt file
493 (dir, file) = splitName f
494 (base, _) = splitExt file
495 in return (f, dir, base)
496 _ -> onlyOne "output file"
498 let cProgName = outDir++outBase++"_hsc_make.c"
499 oProgName = outDir++outBase++"_hsc_make.o"
500 progName = outDir++outBase++"_hsc_make"
501 #if defined(mingw32_HOST_OS)
502 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
503 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
506 outHFile = outBase++"_hsc.h"
507 outHName = outDir++outHFile
508 outCName = outDir++outBase++"_hsc.c"
510 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
513 | null outDir = dosifyPath ("./" ++ progName)
514 | otherwise = progName
516 let specials = [(pos, key, arg) | Special pos key arg <- toks]
518 let needsC = any (\(_, key, _) -> key == "def") specials
521 let includeGuard = map fixChar outHName
523 fixChar c | isAlphaNum c = toUpper c
526 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
527 -- Returns a native-format path
529 mb <- getExecDir "bin/hsc2hs.exe"
531 Nothing -> return def
533 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
534 flg <- doesFileExist ghc_path
539 -- On a Win32 installation we execute the hsc2hs binary directly,
540 -- with no --cc flags, so we'll call locateGhc here, which will
541 -- succeed, via getExecDir.
543 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
544 -- (called plain hsc2hs in the installed tree), which will pass
545 -- a suitable C compiler via --cc
547 -- The in-place installation always uses the wrapper script,
548 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
549 compiler <- case [c | Compiler c <- flags] of
550 [] -> locateGhc "ghc"
552 _ -> onlyOne "compiler"
554 linker <- case [l | Linker l <- flags] of
555 [] -> locateGhc compiler
557 _ -> onlyOne "linker"
559 writeFile cProgName $
560 concatMap outFlagHeaderCProg flags++
561 concatMap outHeaderCProg specials++
562 "\nint main (int argc, char *argv [])\n{\n"++
563 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
564 outHsLine (SourcePos name 0)++
565 concatMap outTokenHs toks++
568 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
569 -- so we use something slightly more complicated. :-P
570 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
575 compilerStatus <- rawSystemL beVerbose compiler
577 ++ [f | CompFlag f <- flags]
582 case compilerStatus of
583 e@(ExitFailure _) -> exitWith e
587 linkerStatus <- rawSystemL beVerbose linker
588 ( [f | LinkFlag f <- flags]
594 e@(ExitFailure _) -> exitWith e
598 progStatus <- systemL beVerbose (execProgName++" >"++outName)
601 e@(ExitFailure _) -> exitWith e
604 when needsH $ writeFile outHName $
605 "#ifndef "++includeGuard++"\n" ++
606 "#define "++includeGuard++"\n" ++
607 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
608 "#include <Rts.h>\n" ++
610 "#include <HsFFI.h>\n" ++
613 "#define HsChar int\n" ++
615 concatMap outFlagH flags++
616 concatMap outTokenH specials++
619 when needsC $ writeFile outCName $
620 "#include \""++outHFile++"\"\n"++
621 concatMap outTokenC specials
622 -- NB. outHFile not outHName; works better when processed
623 -- by gcc or mkdependC.
625 rawSystemL :: Bool -> String -> [String] -> IO ExitCode
626 rawSystemL flg prog args = do
627 when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
630 systemL :: Bool -> String -> IO ExitCode
632 when flg (hPutStrLn stderr ("Executing: " ++ s))
635 onlyOne :: String -> IO a
636 onlyOne what = die ("Only one "++what++" may be specified\n")
638 outFlagHeaderCProg :: Flag -> String
639 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
640 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
641 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
642 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
643 outFlagHeaderCProg _ = ""
645 outHeaderCProg :: (SourcePos, String, String) -> String
646 outHeaderCProg (pos, key, arg) = case key of
647 "include" -> outCLine pos++"#include "++arg++"\n"
648 "define" -> outCLine pos++"#define "++arg++"\n"
649 "undef" -> outCLine pos++"#undef "++arg++"\n"
651 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
652 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
654 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
655 "let" -> case break (== '=') arg of
657 (header, _:body) -> case break isSpace header of
660 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
661 "printf ("++joinLines body++");\n"
664 joinLines = concat . intersperse " \\\n" . lines
666 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
667 outHeaderHs flags inH toks =
669 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
670 " printf (\"{-# OPTIONS -optc-D" ++
671 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
672 "__GLASGOW_HASKELL__);\n" ++
675 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
676 Just f -> outOption ("-#include \""++f++"\"")
678 outFlag (Include f) = outOption ("-#include "++f)
679 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
680 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
682 outSpecial (pos, key, arg) = case key of
683 "include" -> outOption ("-#include "++arg)
684 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
686 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
688 goodForOptD arg = case arg of
690 c:_ | isSpace c -> True
693 toOptD arg = case break isSpace arg of
695 (name, _:value) -> name++'=':dropWhile isSpace value
696 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
697 showCString s++"\");\n"
699 outTokenHs :: Token -> String
700 outTokenHs (Text pos txt) =
701 case break (== '\n') txt of
702 (allTxt, []) -> outText allTxt
704 outText (first++"\n")++
708 outText s = " fputs (\""++showCString s++"\", stdout);\n"
709 outTokenHs (Special pos key arg) =
715 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
717 "enum" -> outCLine pos++outEnum arg
718 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
720 outEnum :: String -> String
722 case break (== ',') arg of
724 (t, _:afterT) -> case break (== ',') afterT of
727 enums (_:s) = case break (== ',') s of
729 this = case break (== '=') $ dropWhile isSpace enum of
731 " hsc_enum ("++t++", "++f++", " ++
732 "hsc_haskellize (\""++name++"\"), "++
735 " hsc_enum ("++t++", "++f++", " ++
736 "printf (\"%s\", \""++hsName++"\"), "++
741 outFlagH :: Flag -> String
742 outFlagH (Include f) = "#include "++f++"\n"
743 outFlagH (Define n Nothing) = "#define "++n++"\n"
744 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
747 outTokenH :: (SourcePos, String, String) -> String
748 outTokenH (pos, key, arg) =
750 "include" -> outCLine pos++"#include "++arg++"\n"
751 "define" -> outCLine pos++"#define " ++arg++"\n"
752 "undef" -> outCLine pos++"#undef " ++arg++"\n"
753 "def" -> outCLine pos++case arg of
754 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
755 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
756 'i':'n':'l':'i':'n':'e':' ':_ ->
757 "#ifdef __GNUC__\n" ++
761 _ -> "extern "++header++";\n"
762 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
763 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
766 outTokenC :: (SourcePos, String, String) -> String
767 outTokenC (pos, key, arg) =
770 's':'t':'r':'u':'c':'t':' ':_ -> ""
771 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
772 'i':'n':'l':'i':'n':'e':' ':arg' ->
773 case span (\c -> c /= '{' && c /= '=') arg' of
776 "#ifndef __GNUC__\n" ++
780 "\n#ifndef __GNUC__\n" ++
785 _ -> outCLine pos++arg++"\n"
786 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
789 conditional :: String -> Bool
790 conditional "if" = True
791 conditional "ifdef" = True
792 conditional "ifndef" = True
793 conditional "elif" = True
794 conditional "else" = True
795 conditional "endif" = True
796 conditional "error" = True
797 conditional "warning" = True
798 conditional _ = False
800 outCLine :: SourcePos -> String
801 outCLine (SourcePos name line) =
802 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
804 outHsLine :: SourcePos -> String
805 outHsLine (SourcePos name line) =
806 " hsc_line ("++show (line + 1)++", \""++
807 showCString (snd (splitName name))++"\");\n"
809 showCString :: String -> String
810 showCString = concatMap showCChar
812 showCChar '\"' = "\\\""
813 showCChar '\'' = "\\\'"
814 showCChar '?' = "\\?"
815 showCChar '\\' = "\\\\"
816 showCChar c | c >= ' ' && c <= '~' = [c]
817 showCChar '\a' = "\\a"
818 showCChar '\b' = "\\b"
819 showCChar '\f' = "\\f"
820 showCChar '\n' = "\\n\"\n \""
821 showCChar '\r' = "\\r"
822 showCChar '\t' = "\\t"
823 showCChar '\v' = "\\v"
825 intToDigit (ord c `quot` 64),
826 intToDigit (ord c `quot` 8 `mod` 8),
827 intToDigit (ord c `mod` 8)]
831 -----------------------------------------
832 -- Cut and pasted from ghc/compiler/SysTools
833 -- Convert paths foo/baz to foo\baz on Windows
835 dosifyPath :: String -> String
836 #if defined(mingw32_HOST_OS)
837 dosifyPath xs = subst '/' '\\' xs
839 unDosifyPath :: String -> String
840 unDosifyPath xs = subst '\\' '/' xs
842 subst :: Eq a => a -> a -> [a] -> [a]
843 subst a b ls = map (\ x -> if x == a then b else x) ls
845 getExecDir :: String -> IO (Maybe String)
846 -- (getExecDir cmd) returns the directory in which the current
847 -- executable, which should be called 'cmd', is running
848 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
849 -- you'll get "/a/b/c" back as the result
851 = allocaArray len $ \buf -> do
852 ret <- getModuleFileName nullPtr buf len
853 if ret == 0 then return Nothing
854 else do s <- peekCString buf
855 return (Just (reverse (drop (length cmd)
856 (reverse (unDosifyPath s)))))
858 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
860 foreign import stdcall unsafe "GetModuleFileNameA"
861 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
866 getExecDir :: String -> IO (Maybe String)
867 getExecDir _ = return Nothing