1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.71 2005/01/29 12:15:33 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 defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
15 #include "../../includes/ghcconfig.h"
18 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
19 import System.Console.GetOpt
24 import System (getProgName, getArgs, ExitCode(..), exitWith, system)
25 import Directory (removeFile,doesFileExist)
26 import Monad (MonadPlus(..), liftM, liftM2, when)
27 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
28 import List (intersperse, isSuffixOf)
29 import IO (hPutStr, hPutStrLn, stderr)
31 #if defined(mingw32_HOST_OS) && !__HUGS__
33 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
34 import Foreign.C.String
41 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
42 import Compat.RawSystem ( rawSystem )
43 #elif __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
44 import System.Cmd ( rawSystem )
46 rawSystem prog args = system (prog++" "++unwords args)
50 version = "hsc2hs version 0.66\n"
62 | Define String (Maybe String)
66 template_flag :: Flag -> Bool
67 template_flag (Template _) = True
68 template_flag _ = False
70 include :: String -> Flag
71 include s@('\"':_) = Include s
72 include s@('<' :_) = Include s
73 include s = Include ("\""++s++"\"")
75 define :: String -> Flag
76 define s = case break (== '=') s of
77 (name, []) -> Define name Nothing
78 (name, _:value) -> Define name (Just value)
80 options :: [OptDescr Flag]
82 Option ['o'] ["output"] (ReqArg Output "FILE")
83 "name of main output file",
84 Option ['t'] ["template"] (ReqArg Template "FILE")
86 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
88 Option ['l'] ["ld"] (ReqArg Linker "PROG")
90 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
91 "flag to pass to the C compiler",
92 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
93 "passed to the C compiler",
94 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
95 "flag to pass to the linker",
96 Option ['i'] ["include"] (ReqArg include "FILE")
97 "as if placed in the source",
98 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
99 "as if placed in the source",
100 Option [] ["no-compile"] (NoArg NoCompile)
101 "stop after writing *_hsc_make.c",
102 Option ['v'] ["verbose"] (NoArg Verbose)
103 "dump commands to stderr",
104 Option ['?'] ["help"] (NoArg Help)
105 "display this help and exit",
106 Option ['V'] ["version"] (NoArg Version)
107 "output version information and exit" ]
112 prog <- getProgramName
113 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
115 let (flags, files, errs) = getOpt Permute options args
117 -- If there is no Template flag explicitly specified, try
118 -- to find one by looking near the executable. This only
119 -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
120 -- script which specifies an explicit template flag.
121 flags_w_tpl <- if any template_flag flags then
125 do mb_path <- getExecDir "/Main.hs"
127 do mb_path <- getExecDir "/bin/hsc2hs.exe"
133 let templ = path ++ "/template-hsc.h"
134 flg <- doesFileExist templ
136 then return ((Template templ):)
138 return (add_opt flags)
139 case (files, errs) of
141 | any isHelp flags_w_tpl -> bye (usageInfo header options)
142 | any isVersion flags_w_tpl -> bye version
144 isHelp Help = True; isHelp _ = False
145 isVersion Version = True; isVersion _ = False
146 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
147 (_, _ ) -> die (concat errs ++ usageInfo header options)
149 getProgramName :: IO String
150 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
151 where str `withoutSuffix` suff
152 | suff `isSuffixOf` str = take (length str - length suff) str
155 bye :: String -> IO a
156 bye s = putStr s >> exitWith ExitSuccess
158 die :: String -> IO a
159 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
161 processFile :: [Flag] -> String -> IO ()
162 processFile flags name
163 = do let file_name = dosifyPath name
164 s <- readFile file_name
166 Parser p -> case p (SourcePos file_name 1) s of
167 Success _ _ _ toks -> output flags file_name toks
168 Failure (SourcePos name' line) msg ->
169 die (name'++":"++show line++": "++msg++"\n")
171 ------------------------------------------------------------------------
172 -- A deterministic parser which remembers the text which has been parsed.
174 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
176 data ParseResult a = Success !SourcePos String String a
177 | Failure !SourcePos String
179 data SourcePos = SourcePos String !Int
181 updatePos :: SourcePos -> Char -> SourcePos
182 updatePos pos@(SourcePos name line) ch = case ch of
183 '\n' -> SourcePos name (line + 1)
186 instance Monad Parser where
187 return a = Parser $ \pos s -> Success pos [] s a
189 Parser $ \pos s -> case m pos s of
190 Success pos' out1 s' a -> case k a of
191 Parser k' -> case k' pos' s' of
192 Success pos'' out2 imp'' b ->
193 Success pos'' (out1++out2) imp'' b
194 Failure pos'' msg -> Failure pos'' msg
195 Failure pos' msg -> Failure pos' msg
196 fail msg = Parser $ \pos _ -> Failure pos msg
198 instance MonadPlus Parser where
200 Parser m `mplus` Parser n =
201 Parser $ \pos s -> case m pos s of
202 success@(Success _ _ _ _) -> success
203 Failure _ _ -> n pos s
205 getPos :: Parser SourcePos
206 getPos = Parser $ \pos s -> Success pos [] s pos
208 setPos :: SourcePos -> Parser ()
209 setPos pos = Parser $ \_ s -> Success pos [] s ()
211 message :: Parser a -> String -> Parser a
212 Parser m `message` msg =
213 Parser $ \pos s -> case m pos s of
214 success@(Success _ _ _ _) -> success
215 Failure pos' _ -> Failure pos' msg
217 catchOutput_ :: Parser a -> Parser String
218 catchOutput_ (Parser m) =
219 Parser $ \pos s -> case m pos s of
220 Success pos' out s' _ -> Success pos' [] s' out
221 Failure pos' msg -> Failure pos' msg
223 fakeOutput :: Parser a -> String -> Parser a
224 Parser m `fakeOutput` out =
225 Parser $ \pos s -> case m pos s of
226 Success pos' _ s' a -> Success pos' out s' a
227 Failure pos' msg -> Failure pos' msg
229 lookAhead :: Parser String
230 lookAhead = Parser $ \pos s -> Success pos [] s s
232 satisfy :: (Char -> Bool) -> Parser Char
234 Parser $ \pos s -> case s of
235 c:cs | p c -> Success (updatePos pos c) [c] cs c
236 _ -> Failure pos "Bad character"
238 char_ :: Char -> Parser ()
240 satisfy (== c) `message` (show c++" expected")
243 anyChar_ :: Parser ()
245 satisfy (const True) `message` "Unexpected end of file"
248 any2Chars_ :: Parser ()
249 any2Chars_ = anyChar_ >> anyChar_
251 many :: Parser a -> Parser [a]
252 many p = many1 p `mplus` return []
254 many1 :: Parser a -> Parser [a]
255 many1 p = liftM2 (:) p (many p)
257 many_ :: Parser a -> Parser ()
258 many_ p = many1_ p `mplus` return ()
260 many1_ :: Parser a -> Parser ()
261 many1_ p = p >> many_ p
263 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
264 manySatisfy = many . satisfy
265 manySatisfy1 = many1 . satisfy
267 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
268 manySatisfy_ = many_ . satisfy
269 manySatisfy1_ = many1_ . satisfy
271 ------------------------------------------------------------------------
272 -- Parser of hsc syntax.
275 = Text SourcePos String
276 | Special SourcePos String String
278 parser :: Parser [Token]
281 t <- catchOutput_ text
285 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
286 return (if null t then rest else Text pos t : rest)
293 c:_ | isAlpha c || c == '_' -> do
295 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
297 c:_ | isHsSymbol c -> do
298 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
301 '-':'-':symb' | all (== '-') symb' -> do
302 return () `fakeOutput` symb
303 manySatisfy_ (/= '\n')
306 return () `fakeOutput` unescapeHashes symb
308 '\"':_ -> do anyChar_; hsString '\"'; text
309 '\'':_ -> do anyChar_; hsString '\''; text
310 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
311 _:_ -> do anyChar_; text
313 hsString :: Char -> Parser ()
318 c:_ | c == quote -> anyChar_
323 char_ '\\' `mplus` return ()
325 | otherwise -> do any2Chars_; hsString quote
326 _:_ -> do anyChar_; hsString quote
328 hsComment :: Parser ()
333 '-':'}':_ -> any2Chars_
334 '{':'-':_ -> do any2Chars_; hsComment; hsComment
335 _:_ -> do anyChar_; hsComment
337 linePragma :: Parser ()
341 satisfy (\c -> c == 'L' || c == 'l')
342 satisfy (\c -> c == 'I' || c == 'i')
343 satisfy (\c -> c == 'N' || c == 'n')
344 satisfy (\c -> c == 'E' || c == 'e')
345 manySatisfy1_ isSpace
346 line <- liftM read $ manySatisfy1 isDigit
347 manySatisfy1_ isSpace
349 name <- manySatisfy (/= '\"')
355 setPos (SourcePos name (line - 1))
357 isHsSymbol :: Char -> Bool
358 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
359 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
360 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
361 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
362 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
363 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
364 isHsSymbol '~' = True
367 unescapeHashes :: String -> String
368 unescapeHashes [] = []
369 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
370 unescapeHashes (c:s) = c : unescapeHashes s
372 lookAheadC :: Parser String
373 lookAheadC = liftM joinLines lookAhead
376 joinLines ('\\':'\n':s) = joinLines s
377 joinLines (c:s) = c : joinLines s
379 satisfyC :: (Char -> Bool) -> Parser Char
383 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
386 charC_ :: Char -> Parser ()
388 satisfyC (== c) `message` (show c++" expected")
391 anyCharC_ :: Parser ()
393 satisfyC (const True) `message` "Unexpected end of file"
396 any2CharsC_ :: Parser ()
397 any2CharsC_ = anyCharC_ >> anyCharC_
399 manySatisfyC :: (Char -> Bool) -> Parser String
400 manySatisfyC = many . satisfyC
402 manySatisfyC_ :: (Char -> Bool) -> Parser ()
403 manySatisfyC_ = many_ . satisfyC
405 special :: Parser Token
407 manySatisfyC_ (\c -> isSpace c && c /= '\n')
412 manySatisfyC_ isSpace
413 sp <- keyArg (== '\n')
416 _ -> keyArg (const False)
418 keyArg :: (Char -> Bool) -> Parser Token
421 key <- keyword `message` "hsc keyword or '{' expected"
422 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
423 arg <- catchOutput_ (argument eol)
424 return (Special pos key arg)
426 keyword :: Parser String
428 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
429 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
432 argument :: (Char -> Bool) -> Parser ()
437 c:_ | eol c -> do anyCharC_; argument eol
439 '\"':_ -> do anyCharC_; cString '\"'; argument eol
440 '\'':_ -> do anyCharC_; cString '\''; argument eol
441 '(':_ -> do anyCharC_; nested ')'; argument eol
443 '/':'*':_ -> do any2CharsC_; cComment; argument eol
445 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
446 '[':_ -> do anyCharC_; nested ']'; argument eol
448 '{':_ -> do anyCharC_; nested '}'; argument eol
450 _:_ -> do anyCharC_; argument eol
452 nested :: Char -> Parser ()
453 nested c = do argument (== '\n'); charC_ c
455 cComment :: Parser ()
460 '*':'/':_ -> do any2CharsC_
461 _:_ -> do anyCharC_; cComment
463 cString :: Char -> Parser ()
468 c:_ | c == quote -> anyCharC_
469 '\\':_:_ -> do any2CharsC_; cString quote
470 _:_ -> do anyCharC_; cString quote
472 ------------------------------------------------------------------------
473 -- Write the output files.
475 splitName :: String -> (String, String)
477 case break (== '/') name of
478 (file, []) -> ([], file)
479 (dir, sep:rest) -> (dir++sep:restDir, restFile)
481 (restDir, restFile) = splitName rest
483 splitExt :: String -> (String, String)
485 case break (== '.') name of
486 (base, []) -> (base, [])
487 (base, sepRest@(sep:rest))
488 | null restExt -> (base, sepRest)
489 | otherwise -> (base++sep:restBase, restExt)
491 (restBase, restExt) = splitExt rest
493 output :: [Flag] -> String -> [Token] -> IO ()
494 output flags name toks = do
496 (outName, outDir, outBase) <- case [f | Output f <- flags] of
497 [] -> if not (null ext) && last ext == 'c'
498 then return (dir++base++init ext, dir, base)
501 then return (dir++base++"_out.hs", dir, base)
502 else return (dir++base++".hs", dir, base)
504 (dir, file) = splitName name
505 (base, ext) = splitExt file
507 (dir, file) = splitName f
508 (base, _) = splitExt file
509 in return (f, dir, base)
510 _ -> onlyOne "output file"
512 let cProgName = outDir++outBase++"_hsc_make.c"
513 oProgName = outDir++outBase++"_hsc_make.o"
514 progName = outDir++outBase++"_hsc_make"
515 #if defined(mingw32_HOST_OS)
516 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
517 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
520 outHFile = outBase++"_hsc.h"
521 outHName = outDir++outHFile
522 outCName = outDir++outBase++"_hsc.c"
524 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
527 | null outDir = dosifyPath ("./" ++ progName)
528 | otherwise = progName
530 let specials = [(pos, key, arg) | Special pos key arg <- toks]
532 let needsC = any (\(_, key, _) -> key == "def") specials
535 let includeGuard = map fixChar outHName
537 fixChar c | isAlphaNum c = toUpper c
541 compiler <- case [c | Compiler c <- flags] of
544 _ -> onlyOne "compiler"
546 linker <- case [l | Linker l <- flags] of
547 [] -> return compiler
549 _ -> onlyOne "linker"
551 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
552 -- Returns a native-format path
554 mb <- getExecDir "bin/hsc2hs.exe"
556 Nothing -> return def
558 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
559 flg <- doesFileExist ghc_path
564 -- On a Win32 installation we execute the hsc2hs binary directly,
565 -- with no --cc flags, so we'll call locateGhc here, which will
566 -- succeed, via getExecDir.
568 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
569 -- (called plain hsc2hs in the installed tree), which will pass
570 -- a suitable C compiler via --cc
572 -- The in-place installation always uses the wrapper script,
573 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
574 compiler <- case [c | Compiler c <- flags] of
575 [] -> locateGhc "ghc"
577 _ -> onlyOne "compiler"
579 linker <- case [l | Linker l <- flags] of
580 [] -> locateGhc compiler
582 _ -> onlyOne "linker"
585 writeFile cProgName $
586 concatMap outFlagHeaderCProg flags++
587 concatMap outHeaderCProg specials++
588 "\nint main (int argc, char *argv [])\n{\n"++
589 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
590 outHsLine (SourcePos name 0)++
591 concatMap outTokenHs toks++
594 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
595 -- so we use something slightly more complicated. :-P
596 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
601 compilerStatus <- rawSystemL beVerbose compiler
603 ++ [f | CompFlag f <- flags]
608 case compilerStatus of
609 e@(ExitFailure _) -> exitWith e
613 linkerStatus <- rawSystemL beVerbose linker
614 ( [f | LinkFlag f <- flags]
620 e@(ExitFailure _) -> exitWith e
624 progStatus <- systemL beVerbose (execProgName++" >"++outName)
627 e@(ExitFailure _) -> exitWith e
630 when needsH $ writeFile outHName $
631 "#ifndef "++includeGuard++"\n" ++
632 "#define "++includeGuard++"\n" ++
633 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
634 "#include <Rts.h>\n" ++
636 "#include <HsFFI.h>\n" ++
639 "#define HsChar int\n" ++
641 concatMap outFlagH flags++
642 concatMap outTokenH specials++
645 when needsC $ writeFile outCName $
646 "#include \""++outHFile++"\"\n"++
647 concatMap outTokenC specials
648 -- NB. outHFile not outHName; works better when processed
649 -- by gcc or mkdependC.
651 rawSystemL :: Bool -> String -> [String] -> IO ExitCode
652 rawSystemL flg prog args = do
653 when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
656 systemL :: Bool -> String -> IO ExitCode
658 when flg (hPutStrLn stderr ("Executing: " ++ s))
661 onlyOne :: String -> IO a
662 onlyOne what = die ("Only one "++what++" may be specified\n")
664 outFlagHeaderCProg :: Flag -> String
665 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
666 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
667 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
668 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
669 outFlagHeaderCProg _ = ""
671 outHeaderCProg :: (SourcePos, String, String) -> String
672 outHeaderCProg (pos, key, arg) = case key of
673 "include" -> outCLine pos++"#include "++arg++"\n"
674 "define" -> outCLine pos++"#define "++arg++"\n"
675 "undef" -> outCLine pos++"#undef "++arg++"\n"
677 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
678 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
680 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
681 "let" -> case break (== '=') arg of
683 (header, _:body) -> case break isSpace header of
686 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
687 "printf ("++joinLines body++");\n"
690 joinLines = concat . intersperse " \\\n" . lines
692 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
693 outHeaderHs flags inH toks =
695 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
696 " printf (\"{-# OPTIONS -optc-D" ++
697 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
698 "__GLASGOW_HASKELL__);\n" ++
701 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
702 Just f -> outInclude ("\""++f++"\"")
704 outFlag (Include f) = outInclude f
705 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
706 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
708 outSpecial (pos, key, arg) = case key of
709 "include" -> outInclude arg
710 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
712 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
714 goodForOptD arg = case arg of
716 c:_ | isSpace c -> True
719 toOptD arg = case break isSpace arg of
721 (name, _:value) -> name++'=':dropWhile isSpace value
723 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
724 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
725 showCString s++"\");\n"++
727 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
728 showCString s++"\");\n"++
731 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
732 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
733 showCString s++"\");\n"++
735 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
736 showCString s++"\");\n"++
739 outTokenHs :: Token -> String
740 outTokenHs (Text pos txt) =
741 case break (== '\n') txt of
742 (allTxt, []) -> outText allTxt
744 outText (first++"\n")++
748 outText s = " fputs (\""++showCString s++"\", stdout);\n"
749 outTokenHs (Special pos key arg) =
755 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
757 "enum" -> outCLine pos++outEnum arg
758 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
760 outEnum :: String -> String
762 case break (== ',') arg of
764 (t, _:afterT) -> case break (== ',') afterT of
767 enums (_:s) = case break (== ',') s of
769 this = case break (== '=') $ dropWhile isSpace enum of
771 " hsc_enum ("++t++", "++f++", " ++
772 "hsc_haskellize (\""++name++"\"), "++
775 " hsc_enum ("++t++", "++f++", " ++
776 "printf (\"%s\", \""++hsName++"\"), "++
781 outFlagH :: Flag -> String
782 outFlagH (Include f) = "#include "++f++"\n"
783 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
784 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
787 outTokenH :: (SourcePos, String, String) -> String
788 outTokenH (pos, key, arg) =
790 "include" -> outCLine pos++"#include "++arg++"\n"
791 "define" -> outCLine pos++"#define " ++arg++"\n"
792 "undef" -> outCLine pos++"#undef " ++arg++"\n"
793 "def" -> outCLine pos++case arg of
794 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
795 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
796 'i':'n':'l':'i':'n':'e':' ':_ ->
797 "#ifdef __GNUC__\n" ++
801 _ -> "extern "++header++";\n"
802 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
803 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
806 outTokenC :: (SourcePos, String, String) -> String
807 outTokenC (pos, key, arg) =
810 's':'t':'r':'u':'c':'t':' ':_ -> ""
811 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
812 'i':'n':'l':'i':'n':'e':' ':arg' ->
813 case span (\c -> c /= '{' && c /= '=') arg' of
816 "#ifndef __GNUC__\n" ++
820 "\n#ifndef __GNUC__\n" ++
825 _ -> outCLine pos++arg++"\n"
826 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
829 conditional :: String -> Bool
830 conditional "if" = True
831 conditional "ifdef" = True
832 conditional "ifndef" = True
833 conditional "elif" = True
834 conditional "else" = True
835 conditional "endif" = True
836 conditional "error" = True
837 conditional "warning" = True
838 conditional _ = False
840 outCLine :: SourcePos -> String
841 outCLine (SourcePos name line) =
842 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
844 outHsLine :: SourcePos -> String
845 outHsLine (SourcePos name line) =
846 " hsc_line ("++show (line + 1)++", \""++
847 showCString (snd (splitName name))++"\");\n"
849 showCString :: String -> String
850 showCString = concatMap showCChar
852 showCChar '\"' = "\\\""
853 showCChar '\'' = "\\\'"
854 showCChar '?' = "\\?"
855 showCChar '\\' = "\\\\"
856 showCChar c | c >= ' ' && c <= '~' = [c]
857 showCChar '\a' = "\\a"
858 showCChar '\b' = "\\b"
859 showCChar '\f' = "\\f"
860 showCChar '\n' = "\\n\"\n \""
861 showCChar '\r' = "\\r"
862 showCChar '\t' = "\\t"
863 showCChar '\v' = "\\v"
865 intToDigit (ord c `quot` 64),
866 intToDigit (ord c `quot` 8 `mod` 8),
867 intToDigit (ord c `mod` 8)]
871 -----------------------------------------
872 -- Cut and pasted from ghc/compiler/SysTools
873 -- Convert paths foo/baz to foo\baz on Windows
875 dosifyPath, unDosifyPath :: String -> String
876 #if defined(mingw32_HOST_OS)
877 dosifyPath xs = subst '/' '\\' xs
878 unDosifyPath xs = subst '\\' '/' xs
880 subst :: Eq a => a -> a -> [a] -> [a]
881 subst a b ls = map (\ x -> if x == a then b else x) ls
887 getExecDir :: String -> IO (Maybe String)
888 -- (getExecDir cmd) returns the directory in which the current
889 -- executable, which should be called 'cmd', is running
890 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
891 -- you'll get "/a/b/c" back as the result
896 return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s)))))
897 #elif defined(mingw32_HOST_OS)
899 = allocaArray len $ \buf -> do
900 ret <- getModuleFileName nullPtr buf len
901 if ret == 0 then return Nothing
902 else do s <- peekCString buf
903 return (Just (reverse (drop (length cmd)
904 (reverse (unDosifyPath s)))))
906 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
908 foreign import stdcall unsafe "GetModuleFileNameA"
909 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
912 getExecDir _ = return Nothing