1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.60 2004/08/13 13:11:21 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 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
38 version = "hsc2hs version 0.66\n"
50 | Define String (Maybe String)
54 template_flag :: Flag -> Bool
55 template_flag (Template _) = True
56 template_flag _ = False
58 include :: String -> Flag
59 include s@('\"':_) = Include s
60 include s@('<' :_) = Include s
61 include s = Include ("\""++s++"\"")
63 define :: String -> Flag
64 define s = case break (== '=') s of
65 (name, []) -> Define name Nothing
66 (name, _:value) -> Define name (Just value)
68 options :: [OptDescr Flag]
70 Option ['o'] ["output"] (ReqArg Output "FILE")
71 "name of main output file",
72 Option ['t'] ["template"] (ReqArg Template "FILE")
74 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
76 Option ['l'] ["ld"] (ReqArg Linker "PROG")
78 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
79 "flag to pass to the C compiler",
80 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
81 "passed to the C compiler",
82 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
83 "flag to pass to the linker",
84 Option ['i'] ["include"] (ReqArg include "FILE")
85 "as if placed in the source",
86 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
87 "as if placed in the source",
88 Option [] ["no-compile"] (NoArg NoCompile)
89 "stop after writing *_hsc_make.c",
90 Option ['v'] ["verbose"] (NoArg Verbose)
91 "dump commands to stderr",
92 Option ['?'] ["help"] (NoArg Help)
93 "display this help and exit",
94 Option ['V'] ["version"] (NoArg Version)
95 "output version information and exit" ]
100 prog <- getProgramName
101 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
103 let (flags, files, errs) = getOpt Permute options args
105 -- If there is no Template flag explicitly specified, try
106 -- to find one by looking near the executable. This only
107 -- works on Win32 (getExecDir). On Unix, there's a wrapper
108 -- script which specifies an explicit template flag.
109 flags_w_tpl <- if any template_flag flags then
112 do mb_path <- getExecDir "/bin/hsc2hs.exe"
117 let templ = path ++ "/template-hsc.h"
118 flg <- doesFileExist templ
120 then return ((Template templ):)
122 return (add_opt flags)
123 case (files, errs) of
125 | any isHelp flags_w_tpl -> bye (usageInfo header options)
126 | any isVersion flags_w_tpl -> bye version
128 isHelp Help = True; isHelp _ = False
129 isVersion Version = True; isVersion _ = False
130 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
131 (_, _ ) -> die (concat errs ++ usageInfo header options)
133 getProgramName :: IO String
134 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
135 where str `withoutSuffix` suff
136 | suff `isSuffixOf` str = take (length str - length suff) str
139 bye :: String -> IO a
140 bye s = putStr s >> exitWith ExitSuccess
142 die :: String -> IO a
143 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
145 processFile :: [Flag] -> String -> IO ()
146 processFile flags name
147 = do let file_name = dosifyPath name
148 s <- readFile file_name
150 Parser p -> case p (SourcePos file_name 1) s of
151 Success _ _ _ toks -> output flags file_name toks
152 Failure (SourcePos name' line) msg ->
153 die (name'++":"++show line++": "++msg++"\n")
155 ------------------------------------------------------------------------
156 -- A deterministic parser which remembers the text which has been parsed.
158 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
160 data ParseResult a = Success !SourcePos String String a
161 | Failure !SourcePos String
163 data SourcePos = SourcePos String !Int
165 updatePos :: SourcePos -> Char -> SourcePos
166 updatePos pos@(SourcePos name line) ch = case ch of
167 '\n' -> SourcePos name (line + 1)
170 instance Monad Parser where
171 return a = Parser $ \pos s -> Success pos [] s a
173 Parser $ \pos s -> case m pos s of
174 Success pos' out1 s' a -> case k a of
175 Parser k' -> case k' pos' s' of
176 Success pos'' out2 imp'' b ->
177 Success pos'' (out1++out2) imp'' b
178 Failure pos'' msg -> Failure pos'' msg
179 Failure pos' msg -> Failure pos' msg
180 fail msg = Parser $ \pos _ -> Failure pos msg
182 instance MonadPlus Parser where
184 Parser m `mplus` Parser n =
185 Parser $ \pos s -> case m pos s of
186 success@(Success _ _ _ _) -> success
187 Failure _ _ -> n pos s
189 getPos :: Parser SourcePos
190 getPos = Parser $ \pos s -> Success pos [] s pos
192 setPos :: SourcePos -> Parser ()
193 setPos pos = Parser $ \_ s -> Success pos [] s ()
195 message :: Parser a -> String -> Parser a
196 Parser m `message` msg =
197 Parser $ \pos s -> case m pos s of
198 success@(Success _ _ _ _) -> success
199 Failure pos' _ -> Failure pos' msg
201 catchOutput_ :: Parser a -> Parser String
202 catchOutput_ (Parser m) =
203 Parser $ \pos s -> case m pos s of
204 Success pos' out s' _ -> Success pos' [] s' out
205 Failure pos' msg -> Failure pos' msg
207 fakeOutput :: Parser a -> String -> Parser a
208 Parser m `fakeOutput` out =
209 Parser $ \pos s -> case m pos s of
210 Success pos' _ s' a -> Success pos' out s' a
211 Failure pos' msg -> Failure pos' msg
213 lookAhead :: Parser String
214 lookAhead = Parser $ \pos s -> Success pos [] s s
216 satisfy :: (Char -> Bool) -> Parser Char
218 Parser $ \pos s -> case s of
219 c:cs | p c -> Success (updatePos pos c) [c] cs c
220 _ -> Failure pos "Bad character"
222 char_ :: Char -> Parser ()
224 satisfy (== c) `message` (show c++" expected")
227 anyChar_ :: Parser ()
229 satisfy (const True) `message` "Unexpected end of file"
232 any2Chars_ :: Parser ()
233 any2Chars_ = anyChar_ >> anyChar_
235 many :: Parser a -> Parser [a]
236 many p = many1 p `mplus` return []
238 many1 :: Parser a -> Parser [a]
239 many1 p = liftM2 (:) p (many p)
241 many_ :: Parser a -> Parser ()
242 many_ p = many1_ p `mplus` return ()
244 many1_ :: Parser a -> Parser ()
245 many1_ p = p >> many_ p
247 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
248 manySatisfy = many . satisfy
249 manySatisfy1 = many1 . satisfy
251 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
252 manySatisfy_ = many_ . satisfy
253 manySatisfy1_ = many1_ . satisfy
255 ------------------------------------------------------------------------
256 -- Parser of hsc syntax.
259 = Text SourcePos String
260 | Special SourcePos String String
262 parser :: Parser [Token]
265 t <- catchOutput_ text
269 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
270 return (if null t then rest else Text pos t : rest)
277 c:_ | isAlpha c || c == '_' -> do
279 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
281 c:_ | isHsSymbol c -> do
282 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
285 '-':'-':symb' | all (== '-') symb' -> do
286 return () `fakeOutput` symb
287 manySatisfy_ (/= '\n')
290 return () `fakeOutput` unescapeHashes symb
292 '\"':_ -> do anyChar_; hsString '\"'; text
293 '\'':_ -> do anyChar_; hsString '\''; text
294 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
295 _:_ -> do anyChar_; text
297 hsString :: Char -> Parser ()
302 c:_ | c == quote -> anyChar_
307 char_ '\\' `mplus` return ()
309 | otherwise -> do any2Chars_; hsString quote
310 _:_ -> do anyChar_; hsString quote
312 hsComment :: Parser ()
317 '-':'}':_ -> any2Chars_
318 '{':'-':_ -> do any2Chars_; hsComment; hsComment
319 _:_ -> do anyChar_; hsComment
321 linePragma :: Parser ()
325 satisfy (\c -> c == 'L' || c == 'l')
326 satisfy (\c -> c == 'I' || c == 'i')
327 satisfy (\c -> c == 'N' || c == 'n')
328 satisfy (\c -> c == 'E' || c == 'e')
329 manySatisfy1_ isSpace
330 line <- liftM read $ manySatisfy1 isDigit
331 manySatisfy1_ isSpace
333 name <- manySatisfy (/= '\"')
339 setPos (SourcePos name (line - 1))
341 isHsSymbol :: Char -> Bool
342 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
343 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
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
351 unescapeHashes :: String -> String
352 unescapeHashes [] = []
353 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
354 unescapeHashes (c:s) = c : unescapeHashes s
356 lookAheadC :: Parser String
357 lookAheadC = liftM joinLines lookAhead
360 joinLines ('\\':'\n':s) = joinLines s
361 joinLines (c:s) = c : joinLines s
363 satisfyC :: (Char -> Bool) -> Parser Char
367 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
370 charC_ :: Char -> Parser ()
372 satisfyC (== c) `message` (show c++" expected")
375 anyCharC_ :: Parser ()
377 satisfyC (const True) `message` "Unexpected end of file"
380 any2CharsC_ :: Parser ()
381 any2CharsC_ = anyCharC_ >> anyCharC_
383 manySatisfyC :: (Char -> Bool) -> Parser String
384 manySatisfyC = many . satisfyC
386 manySatisfyC_ :: (Char -> Bool) -> Parser ()
387 manySatisfyC_ = many_ . satisfyC
389 special :: Parser Token
391 manySatisfyC_ (\c -> isSpace c && c /= '\n')
396 manySatisfyC_ isSpace
397 sp <- keyArg (== '\n')
400 _ -> keyArg (const False)
402 keyArg :: (Char -> Bool) -> Parser Token
405 key <- keyword `message` "hsc keyword or '{' expected"
406 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
407 arg <- catchOutput_ (argument eol)
408 return (Special pos key arg)
410 keyword :: Parser String
412 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
413 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
416 argument :: (Char -> Bool) -> Parser ()
421 c:_ | eol c -> do anyCharC_; argument eol
423 '\"':_ -> do anyCharC_; cString '\"'; argument eol
424 '\'':_ -> do anyCharC_; cString '\''; argument eol
425 '(':_ -> do anyCharC_; nested ')'; argument eol
427 '/':'*':_ -> do any2CharsC_; cComment; argument eol
429 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
430 '[':_ -> do anyCharC_; nested ']'; argument eol
432 '{':_ -> do anyCharC_; nested '}'; argument eol
434 _:_ -> do anyCharC_; argument eol
436 nested :: Char -> Parser ()
437 nested c = do argument (== '\n'); charC_ c
439 cComment :: Parser ()
444 '*':'/':_ -> do any2CharsC_
445 _:_ -> do anyCharC_; cComment
447 cString :: Char -> Parser ()
452 c:_ | c == quote -> anyCharC_
453 '\\':_:_ -> do any2CharsC_; cString quote
454 _:_ -> do anyCharC_; cString quote
456 ------------------------------------------------------------------------
457 -- Write the output files.
459 splitName :: String -> (String, String)
461 case break (== '/') name of
462 (file, []) -> ([], file)
463 (dir, sep:rest) -> (dir++sep:restDir, restFile)
465 (restDir, restFile) = splitName rest
467 splitExt :: String -> (String, String)
469 case break (== '.') name of
470 (base, []) -> (base, [])
471 (base, sepRest@(sep:rest))
472 | null restExt -> (base, sepRest)
473 | otherwise -> (base++sep:restBase, restExt)
475 (restBase, restExt) = splitExt rest
477 output :: [Flag] -> String -> [Token] -> IO ()
478 output flags name toks = do
480 (outName, outDir, outBase) <- case [f | Output f <- flags] of
481 [] -> if not (null ext) && last ext == 'c'
482 then return (dir++base++init ext, dir, base)
485 then return (dir++base++"_out.hs", dir, base)
486 else return (dir++base++".hs", dir, base)
488 (dir, file) = splitName name
489 (base, ext) = splitExt file
491 (dir, file) = splitName f
492 (base, _) = splitExt file
493 in return (f, dir, base)
494 _ -> onlyOne "output file"
496 let cProgName = outDir++outBase++"_hsc_make.c"
497 oProgName = outDir++outBase++"_hsc_make.o"
498 progName = outDir++outBase++"_hsc_make"
499 #if defined(mingw32_HOST_OS)
500 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
501 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
504 outHFile = outBase++"_hsc.h"
505 outHName = outDir++outHFile
506 outCName = outDir++outBase++"_hsc.c"
508 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
511 | null outDir = dosifyPath ("./" ++ progName)
512 | otherwise = progName
514 let specials = [(pos, key, arg) | Special pos key arg <- toks]
516 let needsC = any (\(_, key, _) -> key == "def") specials
519 let includeGuard = map fixChar outHName
521 fixChar c | isAlphaNum c = toUpper c
524 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
525 -- Returns a native-format path
527 mb <- getExecDir "bin/hsc2hs.exe"
529 Nothing -> return def
531 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
532 flg <- doesFileExist ghc_path
537 -- On a Win32 installation we execute the hsc2hs binary directly,
538 -- with no --cc flags, so we'll call locateGhc here, which will
539 -- succeed, via getExecDir.
541 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
542 -- (called plain hsc2hs in the installed tree), which will pass
543 -- a suitable C compiler via --cc
545 -- The in-place installation always uses the wrapper script,
546 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
547 compiler <- case [c | Compiler c <- flags] of
548 [] -> locateGhc "ghc"
550 _ -> onlyOne "compiler"
552 linker <- case [l | Linker l <- flags] of
553 [] -> locateGhc compiler
555 _ -> onlyOne "linker"
557 writeFile cProgName $
558 concatMap outFlagHeaderCProg flags++
559 concatMap outHeaderCProg specials++
560 "\nint main (int argc, char *argv [])\n{\n"++
561 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
562 outHsLine (SourcePos name 0)++
563 concatMap outTokenHs toks++
566 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
567 -- so we use something slightly more complicated. :-P
568 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
573 compilerStatus <- systemL beVerbose $
576 concat [" "++f | CompFlag f <- flags]++
579 case compilerStatus of
580 e@(ExitFailure _) -> exitWith e
584 linkerStatus <- systemL beVerbose $
586 concat [" "++f | LinkFlag f <- flags]++
590 e@(ExitFailure _) -> exitWith e
594 progStatus <- systemL beVerbose (execProgName++" >"++outName)
597 e@(ExitFailure _) -> exitWith e
600 when needsH $ writeFile outHName $
601 "#ifndef "++includeGuard++"\n" ++
602 "#define "++includeGuard++"\n" ++
603 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
604 "#include <Rts.h>\n" ++
606 "#include <HsFFI.h>\n" ++
609 "#define HsChar int\n" ++
611 concatMap outFlagH flags++
612 concatMap outTokenH specials++
615 when needsC $ writeFile outCName $
616 "#include \""++outHFile++"\"\n"++
617 concatMap outTokenC specials
618 -- NB. outHFile not outHName; works better when processed
619 -- by gcc or mkdependC.
621 systemL :: Bool -> String -> IO ExitCode
623 when flg (hPutStrLn stderr ("Executing: " ++ s))
626 onlyOne :: String -> IO a
627 onlyOne what = die ("Only one "++what++" may be specified\n")
629 outFlagHeaderCProg :: Flag -> String
630 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
631 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
632 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
633 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
634 outFlagHeaderCProg _ = ""
636 outHeaderCProg :: (SourcePos, String, String) -> String
637 outHeaderCProg (pos, key, arg) = case key of
638 "include" -> outCLine pos++"#include "++arg++"\n"
639 "define" -> outCLine pos++"#define "++arg++"\n"
640 "undef" -> outCLine pos++"#undef "++arg++"\n"
642 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
643 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
645 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
646 "let" -> case break (== '=') arg of
648 (header, _:body) -> case break isSpace header of
651 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
652 "printf ("++joinLines body++");\n"
655 joinLines = concat . intersperse " \\\n" . lines
657 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
658 outHeaderHs flags inH toks =
660 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
661 " printf (\"{-# OPTIONS -optc-D" ++
662 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
663 "__GLASGOW_HASKELL__);\n" ++
666 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
667 Just f -> outOption ("-#include \""++f++"\"")
669 outFlag (Include f) = outOption ("-#include "++f)
670 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
671 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
673 outSpecial (pos, key, arg) = case key of
674 "include" -> outOption ("-#include "++arg)
675 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
677 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
679 goodForOptD arg = case arg of
681 c:_ | isSpace c -> True
684 toOptD arg = case break isSpace arg of
686 (name, _:value) -> name++'=':dropWhile isSpace value
687 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
688 showCString s++"\");\n"
690 outTokenHs :: Token -> String
691 outTokenHs (Text pos txt) =
692 case break (== '\n') txt of
693 (allTxt, []) -> outText allTxt
695 outText (first++"\n")++
699 outText s = " fputs (\""++showCString s++"\", stdout);\n"
700 outTokenHs (Special pos key arg) =
706 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
708 "enum" -> outCLine pos++outEnum arg
709 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
711 outEnum :: String -> String
713 case break (== ',') arg of
715 (t, _:afterT) -> case break (== ',') afterT of
718 enums (_:s) = case break (== ',') s of
720 this = case break (== '=') $ dropWhile isSpace enum of
722 " hsc_enum ("++t++", "++f++", " ++
723 "hsc_haskellize (\""++name++"\"), "++
726 " hsc_enum ("++t++", "++f++", " ++
727 "printf (\"%s\", \""++hsName++"\"), "++
732 outFlagH :: Flag -> String
733 outFlagH (Include f) = "#include "++f++"\n"
734 outFlagH (Define n Nothing) = "#define "++n++"\n"
735 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
738 outTokenH :: (SourcePos, String, String) -> String
739 outTokenH (pos, key, arg) =
741 "include" -> outCLine pos++"#include "++arg++"\n"
742 "define" -> outCLine pos++"#define " ++arg++"\n"
743 "undef" -> outCLine pos++"#undef " ++arg++"\n"
744 "def" -> outCLine pos++case arg of
745 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
746 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
747 'i':'n':'l':'i':'n':'e':' ':_ ->
748 "#ifdef __GNUC__\n" ++
752 _ -> "extern "++header++";\n"
753 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
754 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
757 outTokenC :: (SourcePos, String, String) -> String
758 outTokenC (pos, key, arg) =
761 's':'t':'r':'u':'c':'t':' ':_ -> ""
762 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
763 'i':'n':'l':'i':'n':'e':' ':arg' ->
764 case span (\c -> c /= '{' && c /= '=') arg' of
767 "#ifndef __GNUC__\n" ++
771 "\n#ifndef __GNUC__\n" ++
776 _ -> outCLine pos++arg++"\n"
777 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
780 conditional :: String -> Bool
781 conditional "if" = True
782 conditional "ifdef" = True
783 conditional "ifndef" = True
784 conditional "elif" = True
785 conditional "else" = True
786 conditional "endif" = True
787 conditional "error" = True
788 conditional "warning" = True
789 conditional _ = False
791 outCLine :: SourcePos -> String
792 outCLine (SourcePos name line) =
793 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
795 outHsLine :: SourcePos -> String
796 outHsLine (SourcePos name line) =
797 " hsc_line ("++show (line + 1)++", \""++
798 showCString (snd (splitName name))++"\");\n"
800 showCString :: String -> String
801 showCString = concatMap showCChar
803 showCChar '\"' = "\\\""
804 showCChar '\'' = "\\\'"
805 showCChar '?' = "\\?"
806 showCChar '\\' = "\\\\"
807 showCChar c | c >= ' ' && c <= '~' = [c]
808 showCChar '\a' = "\\a"
809 showCChar '\b' = "\\b"
810 showCChar '\f' = "\\f"
811 showCChar '\n' = "\\n\"\n \""
812 showCChar '\r' = "\\r"
813 showCChar '\t' = "\\t"
814 showCChar '\v' = "\\v"
816 intToDigit (ord c `quot` 64),
817 intToDigit (ord c `quot` 8 `mod` 8),
818 intToDigit (ord c `mod` 8)]
822 -----------------------------------------
823 -- Cut and pasted from ghc/compiler/SysTools
824 -- Convert paths foo/baz to foo\baz on Windows
826 dosifyPath :: String -> String
827 #if defined(mingw32_HOST_OS)
828 dosifyPath xs = subst '/' '\\' xs
830 unDosifyPath :: String -> String
831 unDosifyPath xs = subst '\\' '/' xs
833 subst :: Eq a => a -> a -> [a] -> [a]
834 subst a b ls = map (\ x -> if x == a then b else x) ls
836 getExecDir :: String -> IO (Maybe String)
837 -- (getExecDir cmd) returns the directory in which the current
838 -- executable, which should be called 'cmd', is running
839 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
840 -- you'll get "/a/b/c" back as the result
842 = allocaArray len $ \buf -> do
843 ret <- getModuleFileName nullPtr buf len
844 if ret == 0 then return Nothing
845 else do s <- peekCString buf
846 return (Just (reverse (drop (length cmd)
847 (reverse (unDosifyPath s)))))
849 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
851 foreign import stdcall unsafe "GetModuleFileNameA"
852 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
857 getExecDir :: String -> IO (Maybe String)
858 getExecDir _ = return Nothing