1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.65 2005/01/06 14:54:15 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 )
41 #elif BUILD_NHC && __GLASGOW_HASKELL__ >= 603
42 import Compat.RawSystem ( rawSystem )
44 rawSystem prog args = system (prog++" "++unwords args)
48 version = "hsc2hs version 0.66\n"
60 | Define String (Maybe String)
64 template_flag :: Flag -> Bool
65 template_flag (Template _) = True
66 template_flag _ = False
68 include :: String -> Flag
69 include s@('\"':_) = Include s
70 include s@('<' :_) = Include s
71 include s = Include ("\""++s++"\"")
73 define :: String -> Flag
74 define s = case break (== '=') s of
75 (name, []) -> Define name Nothing
76 (name, _:value) -> Define name (Just value)
78 options :: [OptDescr Flag]
80 Option ['o'] ["output"] (ReqArg Output "FILE")
81 "name of main output file",
82 Option ['t'] ["template"] (ReqArg Template "FILE")
84 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
86 Option ['l'] ["ld"] (ReqArg Linker "PROG")
88 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
89 "flag to pass to the C compiler",
90 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
91 "passed to the C compiler",
92 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
93 "flag to pass to the linker",
94 Option ['i'] ["include"] (ReqArg include "FILE")
95 "as if placed in the source",
96 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
97 "as if placed in the source",
98 Option [] ["no-compile"] (NoArg NoCompile)
99 "stop after writing *_hsc_make.c",
100 Option ['v'] ["verbose"] (NoArg Verbose)
101 "dump commands to stderr",
102 Option ['?'] ["help"] (NoArg Help)
103 "display this help and exit",
104 Option ['V'] ["version"] (NoArg Version)
105 "output version information and exit" ]
110 prog <- getProgramName
111 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
113 let (flags, files, errs) = getOpt Permute options args
115 -- If there is no Template flag explicitly specified, try
116 -- to find one by looking near the executable. This only
117 -- works on Win32 (getExecDir). On Unix, there's a wrapper
118 -- script which specifies an explicit template flag.
119 flags_w_tpl <- if any template_flag flags then
122 do mb_path <- getExecDir "/bin/hsc2hs.exe"
127 let templ = path ++ "/template-hsc.h"
128 flg <- doesFileExist templ
130 then return ((Template templ):)
132 return (add_opt flags)
133 case (files, errs) of
135 | any isHelp flags_w_tpl -> bye (usageInfo header options)
136 | any isVersion flags_w_tpl -> bye version
138 isHelp Help = True; isHelp _ = False
139 isVersion Version = True; isVersion _ = False
140 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
141 (_, _ ) -> die (concat errs ++ usageInfo header options)
143 getProgramName :: IO String
144 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
145 where str `withoutSuffix` suff
146 | suff `isSuffixOf` str = take (length str - length suff) str
149 bye :: String -> IO a
150 bye s = putStr s >> exitWith ExitSuccess
152 die :: String -> IO a
153 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
155 processFile :: [Flag] -> String -> IO ()
156 processFile flags name
157 = do let file_name = dosifyPath name
158 s <- readFile file_name
160 Parser p -> case p (SourcePos file_name 1) s of
161 Success _ _ _ toks -> output flags file_name toks
162 Failure (SourcePos name' line) msg ->
163 die (name'++":"++show line++": "++msg++"\n")
165 ------------------------------------------------------------------------
166 -- A deterministic parser which remembers the text which has been parsed.
168 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
170 data ParseResult a = Success !SourcePos String String a
171 | Failure !SourcePos String
173 data SourcePos = SourcePos String !Int
175 updatePos :: SourcePos -> Char -> SourcePos
176 updatePos pos@(SourcePos name line) ch = case ch of
177 '\n' -> SourcePos name (line + 1)
180 instance Monad Parser where
181 return a = Parser $ \pos s -> Success pos [] s a
183 Parser $ \pos s -> case m pos s of
184 Success pos' out1 s' a -> case k a of
185 Parser k' -> case k' pos' s' of
186 Success pos'' out2 imp'' b ->
187 Success pos'' (out1++out2) imp'' b
188 Failure pos'' msg -> Failure pos'' msg
189 Failure pos' msg -> Failure pos' msg
190 fail msg = Parser $ \pos _ -> Failure pos msg
192 instance MonadPlus Parser where
194 Parser m `mplus` Parser n =
195 Parser $ \pos s -> case m pos s of
196 success@(Success _ _ _ _) -> success
197 Failure _ _ -> n pos s
199 getPos :: Parser SourcePos
200 getPos = Parser $ \pos s -> Success pos [] s pos
202 setPos :: SourcePos -> Parser ()
203 setPos pos = Parser $ \_ s -> Success pos [] s ()
205 message :: Parser a -> String -> Parser a
206 Parser m `message` msg =
207 Parser $ \pos s -> case m pos s of
208 success@(Success _ _ _ _) -> success
209 Failure pos' _ -> Failure pos' msg
211 catchOutput_ :: Parser a -> Parser String
212 catchOutput_ (Parser m) =
213 Parser $ \pos s -> case m pos s of
214 Success pos' out s' _ -> Success pos' [] s' out
215 Failure pos' msg -> Failure pos' msg
217 fakeOutput :: Parser a -> String -> Parser a
218 Parser m `fakeOutput` out =
219 Parser $ \pos s -> case m pos s of
220 Success pos' _ s' a -> Success pos' out s' a
221 Failure pos' msg -> Failure pos' msg
223 lookAhead :: Parser String
224 lookAhead = Parser $ \pos s -> Success pos [] s s
226 satisfy :: (Char -> Bool) -> Parser Char
228 Parser $ \pos s -> case s of
229 c:cs | p c -> Success (updatePos pos c) [c] cs c
230 _ -> Failure pos "Bad character"
232 char_ :: Char -> Parser ()
234 satisfy (== c) `message` (show c++" expected")
237 anyChar_ :: Parser ()
239 satisfy (const True) `message` "Unexpected end of file"
242 any2Chars_ :: Parser ()
243 any2Chars_ = anyChar_ >> anyChar_
245 many :: Parser a -> Parser [a]
246 many p = many1 p `mplus` return []
248 many1 :: Parser a -> Parser [a]
249 many1 p = liftM2 (:) p (many p)
251 many_ :: Parser a -> Parser ()
252 many_ p = many1_ p `mplus` return ()
254 many1_ :: Parser a -> Parser ()
255 many1_ p = p >> many_ p
257 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
258 manySatisfy = many . satisfy
259 manySatisfy1 = many1 . satisfy
261 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
262 manySatisfy_ = many_ . satisfy
263 manySatisfy1_ = many1_ . satisfy
265 ------------------------------------------------------------------------
266 -- Parser of hsc syntax.
269 = Text SourcePos String
270 | Special SourcePos String String
272 parser :: Parser [Token]
275 t <- catchOutput_ text
279 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
280 return (if null t then rest else Text pos t : rest)
287 c:_ | isAlpha c || c == '_' -> do
289 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
291 c:_ | isHsSymbol c -> do
292 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
295 '-':'-':symb' | all (== '-') symb' -> do
296 return () `fakeOutput` symb
297 manySatisfy_ (/= '\n')
300 return () `fakeOutput` unescapeHashes symb
302 '\"':_ -> do anyChar_; hsString '\"'; text
303 '\'':_ -> do anyChar_; hsString '\''; text
304 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
305 _:_ -> do anyChar_; text
307 hsString :: Char -> Parser ()
312 c:_ | c == quote -> anyChar_
317 char_ '\\' `mplus` return ()
319 | otherwise -> do any2Chars_; hsString quote
320 _:_ -> do anyChar_; hsString quote
322 hsComment :: Parser ()
327 '-':'}':_ -> any2Chars_
328 '{':'-':_ -> do any2Chars_; hsComment; hsComment
329 _:_ -> do anyChar_; hsComment
331 linePragma :: Parser ()
335 satisfy (\c -> c == 'L' || c == 'l')
336 satisfy (\c -> c == 'I' || c == 'i')
337 satisfy (\c -> c == 'N' || c == 'n')
338 satisfy (\c -> c == 'E' || c == 'e')
339 manySatisfy1_ isSpace
340 line <- liftM read $ manySatisfy1 isDigit
341 manySatisfy1_ isSpace
343 name <- manySatisfy (/= '\"')
349 setPos (SourcePos name (line - 1))
351 isHsSymbol :: Char -> Bool
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; isHsSymbol '@' = True; isHsSymbol '\\' = True
357 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
358 isHsSymbol '~' = True
361 unescapeHashes :: String -> String
362 unescapeHashes [] = []
363 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
364 unescapeHashes (c:s) = c : unescapeHashes s
366 lookAheadC :: Parser String
367 lookAheadC = liftM joinLines lookAhead
370 joinLines ('\\':'\n':s) = joinLines s
371 joinLines (c:s) = c : joinLines s
373 satisfyC :: (Char -> Bool) -> Parser Char
377 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
380 charC_ :: Char -> Parser ()
382 satisfyC (== c) `message` (show c++" expected")
385 anyCharC_ :: Parser ()
387 satisfyC (const True) `message` "Unexpected end of file"
390 any2CharsC_ :: Parser ()
391 any2CharsC_ = anyCharC_ >> anyCharC_
393 manySatisfyC :: (Char -> Bool) -> Parser String
394 manySatisfyC = many . satisfyC
396 manySatisfyC_ :: (Char -> Bool) -> Parser ()
397 manySatisfyC_ = many_ . satisfyC
399 special :: Parser Token
401 manySatisfyC_ (\c -> isSpace c && c /= '\n')
406 manySatisfyC_ isSpace
407 sp <- keyArg (== '\n')
410 _ -> keyArg (const False)
412 keyArg :: (Char -> Bool) -> Parser Token
415 key <- keyword `message` "hsc keyword or '{' expected"
416 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
417 arg <- catchOutput_ (argument eol)
418 return (Special pos key arg)
420 keyword :: Parser String
422 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
423 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
426 argument :: (Char -> Bool) -> Parser ()
431 c:_ | eol c -> do anyCharC_; argument eol
433 '\"':_ -> do anyCharC_; cString '\"'; argument eol
434 '\'':_ -> do anyCharC_; cString '\''; argument eol
435 '(':_ -> do anyCharC_; nested ')'; argument eol
437 '/':'*':_ -> do any2CharsC_; cComment; argument eol
439 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
440 '[':_ -> do anyCharC_; nested ']'; argument eol
442 '{':_ -> do anyCharC_; nested '}'; argument eol
444 _:_ -> do anyCharC_; argument eol
446 nested :: Char -> Parser ()
447 nested c = do argument (== '\n'); charC_ c
449 cComment :: Parser ()
454 '*':'/':_ -> do any2CharsC_
455 _:_ -> do anyCharC_; cComment
457 cString :: Char -> Parser ()
462 c:_ | c == quote -> anyCharC_
463 '\\':_:_ -> do any2CharsC_; cString quote
464 _:_ -> do anyCharC_; cString quote
466 ------------------------------------------------------------------------
467 -- Write the output files.
469 splitName :: String -> (String, String)
471 case break (== '/') name of
472 (file, []) -> ([], file)
473 (dir, sep:rest) -> (dir++sep:restDir, restFile)
475 (restDir, restFile) = splitName rest
477 splitExt :: String -> (String, String)
479 case break (== '.') name of
480 (base, []) -> (base, [])
481 (base, sepRest@(sep:rest))
482 | null restExt -> (base, sepRest)
483 | otherwise -> (base++sep:restBase, restExt)
485 (restBase, restExt) = splitExt rest
487 output :: [Flag] -> String -> [Token] -> IO ()
488 output flags name toks = do
490 (outName, outDir, outBase) <- case [f | Output f <- flags] of
491 [] -> if not (null ext) && last ext == 'c'
492 then return (dir++base++init ext, dir, base)
495 then return (dir++base++"_out.hs", dir, base)
496 else return (dir++base++".hs", dir, base)
498 (dir, file) = splitName name
499 (base, ext) = splitExt file
501 (dir, file) = splitName f
502 (base, _) = splitExt file
503 in return (f, dir, base)
504 _ -> onlyOne "output file"
506 let cProgName = outDir++outBase++"_hsc_make.c"
507 oProgName = outDir++outBase++"_hsc_make.o"
508 progName = outDir++outBase++"_hsc_make"
509 #if defined(mingw32_HOST_OS)
510 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
511 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
514 outHFile = outBase++"_hsc.h"
515 outHName = outDir++outHFile
516 outCName = outDir++outBase++"_hsc.c"
518 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
521 | null outDir = dosifyPath ("./" ++ progName)
522 | otherwise = progName
524 let specials = [(pos, key, arg) | Special pos key arg <- toks]
526 let needsC = any (\(_, key, _) -> key == "def") specials
529 let includeGuard = map fixChar outHName
531 fixChar c | isAlphaNum c = toUpper c
534 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
535 -- Returns a native-format path
537 mb <- getExecDir "bin/hsc2hs.exe"
539 Nothing -> return def
541 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
542 flg <- doesFileExist ghc_path
547 -- On a Win32 installation we execute the hsc2hs binary directly,
548 -- with no --cc flags, so we'll call locateGhc here, which will
549 -- succeed, via getExecDir.
551 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
552 -- (called plain hsc2hs in the installed tree), which will pass
553 -- a suitable C compiler via --cc
555 -- The in-place installation always uses the wrapper script,
556 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
557 compiler <- case [c | Compiler c <- flags] of
558 [] -> locateGhc "ghc"
560 _ -> onlyOne "compiler"
562 linker <- case [l | Linker l <- flags] of
563 [] -> locateGhc compiler
565 _ -> onlyOne "linker"
567 writeFile cProgName $
568 concatMap outFlagHeaderCProg flags++
569 concatMap outHeaderCProg specials++
570 "\nint main (int argc, char *argv [])\n{\n"++
571 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
572 outHsLine (SourcePos name 0)++
573 concatMap outTokenHs toks++
576 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
577 -- so we use something slightly more complicated. :-P
578 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
583 compilerStatus <- rawSystemL beVerbose compiler
585 ++ [f | CompFlag f <- flags]
590 case compilerStatus of
591 e@(ExitFailure _) -> exitWith e
595 linkerStatus <- rawSystemL beVerbose linker
596 ( [f | LinkFlag f <- flags]
602 e@(ExitFailure _) -> exitWith e
606 progStatus <- systemL beVerbose (execProgName++" >"++outName)
609 e@(ExitFailure _) -> exitWith e
612 when needsH $ writeFile outHName $
613 "#ifndef "++includeGuard++"\n" ++
614 "#define "++includeGuard++"\n" ++
615 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
616 "#include <Rts.h>\n" ++
618 "#include <HsFFI.h>\n" ++
621 "#define HsChar int\n" ++
623 concatMap outFlagH flags++
624 concatMap outTokenH specials++
627 when needsC $ writeFile outCName $
628 "#include \""++outHFile++"\"\n"++
629 concatMap outTokenC specials
630 -- NB. outHFile not outHName; works better when processed
631 -- by gcc or mkdependC.
633 rawSystemL :: Bool -> String -> [String] -> IO ExitCode
634 rawSystemL flg prog args = do
635 when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
638 systemL :: Bool -> String -> IO ExitCode
640 when flg (hPutStrLn stderr ("Executing: " ++ s))
643 onlyOne :: String -> IO a
644 onlyOne what = die ("Only one "++what++" may be specified\n")
646 outFlagHeaderCProg :: Flag -> String
647 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
648 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
649 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
650 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
651 outFlagHeaderCProg _ = ""
653 outHeaderCProg :: (SourcePos, String, String) -> String
654 outHeaderCProg (pos, key, arg) = case key of
655 "include" -> outCLine pos++"#include "++arg++"\n"
656 "define" -> outCLine pos++"#define "++arg++"\n"
657 "undef" -> outCLine pos++"#undef "++arg++"\n"
659 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
660 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
662 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
663 "let" -> case break (== '=') arg of
665 (header, _:body) -> case break isSpace header of
668 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
669 "printf ("++joinLines body++");\n"
672 joinLines = concat . intersperse " \\\n" . lines
674 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
675 outHeaderHs flags inH toks =
677 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
678 " printf (\"{-# OPTIONS -optc-D" ++
679 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
680 "__GLASGOW_HASKELL__);\n" ++
683 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
684 Just f -> outOption ("-#include \""++f++"\"")
686 outFlag (Include f) = outOption ("-#include "++f)
687 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
688 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
690 outSpecial (pos, key, arg) = case key of
691 "include" -> outOption ("-#include "++arg)
692 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
694 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
696 goodForOptD arg = case arg of
698 c:_ | isSpace c -> True
701 toOptD arg = case break isSpace arg of
703 (name, _:value) -> name++'=':dropWhile isSpace value
704 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
705 showCString s++"\");\n"
707 outTokenHs :: Token -> String
708 outTokenHs (Text pos txt) =
709 case break (== '\n') txt of
710 (allTxt, []) -> outText allTxt
712 outText (first++"\n")++
716 outText s = " fputs (\""++showCString s++"\", stdout);\n"
717 outTokenHs (Special pos key arg) =
723 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
725 "enum" -> outCLine pos++outEnum arg
726 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
728 outEnum :: String -> String
730 case break (== ',') arg of
732 (t, _:afterT) -> case break (== ',') afterT of
735 enums (_:s) = case break (== ',') s of
737 this = case break (== '=') $ dropWhile isSpace enum of
739 " hsc_enum ("++t++", "++f++", " ++
740 "hsc_haskellize (\""++name++"\"), "++
743 " hsc_enum ("++t++", "++f++", " ++
744 "printf (\"%s\", \""++hsName++"\"), "++
749 outFlagH :: Flag -> String
750 outFlagH (Include f) = "#include "++f++"\n"
751 outFlagH (Define n Nothing) = "#define "++n++"\n"
752 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
755 outTokenH :: (SourcePos, String, String) -> String
756 outTokenH (pos, key, arg) =
758 "include" -> outCLine pos++"#include "++arg++"\n"
759 "define" -> outCLine pos++"#define " ++arg++"\n"
760 "undef" -> outCLine pos++"#undef " ++arg++"\n"
761 "def" -> outCLine pos++case arg of
762 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
763 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
764 'i':'n':'l':'i':'n':'e':' ':_ ->
765 "#ifdef __GNUC__\n" ++
769 _ -> "extern "++header++";\n"
770 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
771 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
774 outTokenC :: (SourcePos, String, String) -> String
775 outTokenC (pos, key, arg) =
778 's':'t':'r':'u':'c':'t':' ':_ -> ""
779 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
780 'i':'n':'l':'i':'n':'e':' ':arg' ->
781 case span (\c -> c /= '{' && c /= '=') arg' of
784 "#ifndef __GNUC__\n" ++
788 "\n#ifndef __GNUC__\n" ++
793 _ -> outCLine pos++arg++"\n"
794 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
797 conditional :: String -> Bool
798 conditional "if" = True
799 conditional "ifdef" = True
800 conditional "ifndef" = True
801 conditional "elif" = True
802 conditional "else" = True
803 conditional "endif" = True
804 conditional "error" = True
805 conditional "warning" = True
806 conditional _ = False
808 outCLine :: SourcePos -> String
809 outCLine (SourcePos name line) =
810 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
812 outHsLine :: SourcePos -> String
813 outHsLine (SourcePos name line) =
814 " hsc_line ("++show (line + 1)++", \""++
815 showCString (snd (splitName name))++"\");\n"
817 showCString :: String -> String
818 showCString = concatMap showCChar
820 showCChar '\"' = "\\\""
821 showCChar '\'' = "\\\'"
822 showCChar '?' = "\\?"
823 showCChar '\\' = "\\\\"
824 showCChar c | c >= ' ' && c <= '~' = [c]
825 showCChar '\a' = "\\a"
826 showCChar '\b' = "\\b"
827 showCChar '\f' = "\\f"
828 showCChar '\n' = "\\n\"\n \""
829 showCChar '\r' = "\\r"
830 showCChar '\t' = "\\t"
831 showCChar '\v' = "\\v"
833 intToDigit (ord c `quot` 64),
834 intToDigit (ord c `quot` 8 `mod` 8),
835 intToDigit (ord c `mod` 8)]
839 -----------------------------------------
840 -- Cut and pasted from ghc/compiler/SysTools
841 -- Convert paths foo/baz to foo\baz on Windows
843 dosifyPath :: String -> String
844 #if defined(mingw32_HOST_OS)
845 dosifyPath xs = subst '/' '\\' xs
847 unDosifyPath :: String -> String
848 unDosifyPath xs = subst '\\' '/' xs
850 subst :: Eq a => a -> a -> [a] -> [a]
851 subst a b ls = map (\ x -> if x == a then b else x) ls
853 getExecDir :: String -> IO (Maybe String)
854 -- (getExecDir cmd) returns the directory in which the current
855 -- executable, which should be called 'cmd', is running
856 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
857 -- you'll get "/a/b/c" back as the result
859 = allocaArray len $ \buf -> do
860 ret <- getModuleFileName nullPtr buf len
861 if ret == 0 then return Nothing
862 else do s <- peekCString buf
863 return (Just (reverse (drop (length cmd)
864 (reverse (unDosifyPath s)))))
866 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
868 foreign import stdcall unsafe "GetModuleFileNameA"
869 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
874 getExecDir :: String -> IO (Maybe String)
875 getExecDir _ = return Nothing