1 {-# OPTIONS -fglasgow-exts #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.48 2003/08/27 14:11:17 panne 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
15 import System.Console.GetOpt
21 import System (getProgName, getArgs, ExitCode(..), exitWith, system)
22 import Directory (removeFile,doesFileExist)
23 import Monad (MonadPlus(..), liftM, liftM2, when, unless)
24 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
25 import List (intersperse, isSuffixOf)
26 import IO (hPutStr, hPutStrLn, stderr)
28 #include "../../includes/config.h"
30 #ifdef mingw32_HOST_OS
33 #if __GLASGOW_HASKELL__ >= 504
34 import Foreign.C.String
43 version = "hsc2hs version 0.65\n"
55 | Define String (Maybe String)
59 template_flag (Template _) = True
60 template_flag _ = False
62 include :: String -> Flag
63 include s@('\"':_) = Include s
64 include s@('<' :_) = Include s
65 include s = Include ("\""++s++"\"")
67 define :: String -> Flag
68 define s = case break (== '=') s of
69 (name, []) -> Define name Nothing
70 (name, _:value) -> Define name (Just value)
72 options :: [OptDescr Flag]
74 Option ['o'] ["output"] (ReqArg Output "FILE")
75 "name of main output file",
76 Option ['t'] ["template"] (ReqArg Template "FILE")
78 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
80 Option ['l'] ["ld"] (ReqArg Linker "PROG")
82 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
83 "flag to pass to the C compiler",
84 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
85 "passed to the C compiler",
86 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
87 "flag to pass to the linker",
88 Option ['i'] ["include"] (ReqArg include "FILE")
89 "as if placed in the source",
90 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
91 "as if placed in the source",
92 Option [] ["no-compile"] (NoArg NoCompile)
93 "stop after writing *_hsc_make.c",
94 Option ['v'] ["verbose"] (NoArg Verbose)
95 "dump commands to stderr",
96 Option ['?'] ["help"] (NoArg Help)
97 "display this help and exit",
98 Option ['V'] ["version"] (NoArg Version)
99 "output version information and exit" ]
104 prog <- getProgramName
105 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
107 let (flags, files, errs) = getOpt Permute options args
109 -- If there is no Template flag explicitly specified, try
110 -- to find one by looking near the executable. This only
111 -- works on Win32 (getExecDir). On Unix, there's a wrapper
112 -- script which specifies an explicit template flag.
113 flags_w_tpl <- if any template_flag flags then
116 do mb_path <- getExecDir "/bin/hsc2hs.exe"
121 let templ = path ++ "/template-hsc.h"
122 flg <- doesFileExist templ
124 then return ((Template templ):)
126 return (add_opt flags)
127 case (files, errs) of
129 | any isHelp flags_w_tpl -> bye (usageInfo header options)
130 | any isVersion flags_w_tpl -> bye version
132 isHelp Help = True; isHelp _ = False
133 isVersion Version = True; isVersion _ = False
134 (files@(_:_), []) -> mapM_ (processFile flags_w_tpl) files
135 (_, errs) -> die (concat errs ++ usageInfo header options)
137 getProgramName :: IO String
138 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
139 where str `withoutSuffix` suff
140 | suff `isSuffixOf` str = take (length str - length suff) str
143 bye :: String -> IO a
144 bye s = putStr s >> exitWith ExitSuccess
146 die :: String -> IO a
147 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
149 processFile :: [Flag] -> String -> IO ()
150 processFile flags name
151 = do let file_name = dosifyPath name
152 s <- readFile file_name
154 Parser p -> case p (SourcePos file_name 1) s of
155 Success _ _ _ toks -> output flags file_name toks
156 Failure (SourcePos name' line) msg ->
157 die (name'++":"++show line++": "++msg++"\n")
159 ------------------------------------------------------------------------
160 -- A deterministic parser which remembers the text which has been parsed.
162 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
164 data ParseResult a = Success !SourcePos String String a
165 | Failure !SourcePos String
167 data SourcePos = SourcePos String !Int
169 updatePos :: SourcePos -> Char -> SourcePos
170 updatePos pos@(SourcePos name line) ch = case ch of
171 '\n' -> SourcePos name (line + 1)
174 instance Monad Parser where
175 return a = Parser $ \pos s -> Success pos [] s a
177 Parser $ \pos s -> case m pos s of
178 Success pos' out1 s' a -> case k a of
179 Parser k' -> case k' pos' s' of
180 Success pos'' out2 imp'' b ->
181 Success pos'' (out1++out2) imp'' b
182 Failure pos'' msg -> Failure pos'' msg
183 Failure pos' msg -> Failure pos' msg
184 fail msg = Parser $ \pos _ -> Failure pos msg
186 instance MonadPlus Parser where
188 Parser m `mplus` Parser n =
189 Parser $ \pos s -> case m pos s of
190 success@(Success _ _ _ _) -> success
191 Failure _ _ -> n pos s
193 getPos :: Parser SourcePos
194 getPos = Parser $ \pos s -> Success pos [] s pos
196 setPos :: SourcePos -> Parser ()
197 setPos pos = Parser $ \_ s -> Success pos [] s ()
199 message :: Parser a -> String -> Parser a
200 Parser m `message` msg =
201 Parser $ \pos s -> case m pos s of
202 success@(Success _ _ _ _) -> success
203 Failure pos' _ -> Failure pos' msg
205 catchOutput_ :: Parser a -> Parser String
206 catchOutput_ (Parser m) =
207 Parser $ \pos s -> case m pos s of
208 Success pos' out s' _ -> Success pos' [] s' out
209 Failure pos' msg -> Failure pos' msg
211 fakeOutput :: Parser a -> String -> Parser a
212 Parser m `fakeOutput` out =
213 Parser $ \pos s -> case m pos s of
214 Success pos' _ s' a -> Success pos' out s' a
215 Failure pos' msg -> Failure pos' msg
217 lookAhead :: Parser String
218 lookAhead = Parser $ \pos s -> Success pos [] s s
220 satisfy :: (Char -> Bool) -> Parser Char
222 Parser $ \pos s -> case s of
223 c:cs | p c -> Success (updatePos pos c) [c] cs c
224 _ -> Failure pos "Bad character"
226 char_ :: Char -> Parser ()
228 satisfy (== c) `message` (show c++" expected")
231 anyChar_ :: Parser ()
233 satisfy (const True) `message` "Unexpected end of file"
236 any2Chars_ :: Parser ()
237 any2Chars_ = anyChar_ >> anyChar_
239 many :: Parser a -> Parser [a]
240 many p = many1 p `mplus` return []
242 many1 :: Parser a -> Parser [a]
243 many1 p = liftM2 (:) p (many p)
245 many_ :: Parser a -> Parser ()
246 many_ p = many1_ p `mplus` return ()
248 many1_ :: Parser a -> Parser ()
249 many1_ p = p >> many_ p
251 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
252 manySatisfy = many . satisfy
253 manySatisfy1 = many1 . satisfy
255 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
256 manySatisfy_ = many_ . satisfy
257 manySatisfy1_ = many1_ . satisfy
259 ------------------------------------------------------------------------
260 -- Parser of hsc syntax.
263 = Text SourcePos String
264 | Special SourcePos String String
266 parser :: Parser [Token]
269 t <- catchOutput_ text
273 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
274 return (if null t then rest else Text pos t : rest)
281 c:_ | isAlpha c || c == '_' -> do
283 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
285 c:_ | isHsSymbol c -> do
286 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
289 '-':'-':symb' | all (== '-') symb' -> do
290 return () `fakeOutput` symb
291 manySatisfy_ (/= '\n')
294 return () `fakeOutput` unescapeHashes symb
296 '\"':_ -> do anyChar_; hsString '\"'; text
297 '\'':_ -> do anyChar_; hsString '\''; text
298 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
299 _:_ -> do anyChar_; text
301 hsString :: Char -> Parser ()
306 c:_ | c == quote -> anyChar_
311 char_ '\\' `mplus` return ()
313 | otherwise -> do any2Chars_; hsString quote
314 _:_ -> do anyChar_; hsString quote
316 hsComment :: Parser ()
321 '-':'}':_ -> any2Chars_
322 '{':'-':_ -> do any2Chars_; hsComment; hsComment
323 _:_ -> do anyChar_; hsComment
325 linePragma :: Parser ()
329 satisfy (\c -> c == 'L' || c == 'l')
330 satisfy (\c -> c == 'I' || c == 'i')
331 satisfy (\c -> c == 'N' || c == 'n')
332 satisfy (\c -> c == 'E' || c == 'e')
333 manySatisfy1_ isSpace
334 line <- liftM read $ manySatisfy1 isDigit
335 manySatisfy1_ isSpace
337 name <- manySatisfy (/= '\"')
343 setPos (SourcePos name (line - 1))
345 isHsSymbol :: Char -> Bool
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; isHsSymbol '@' = True; isHsSymbol '\\' = True
351 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
352 isHsSymbol '~' = True
355 unescapeHashes :: String -> String
356 unescapeHashes [] = []
357 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
358 unescapeHashes (c:s) = c : unescapeHashes s
360 lookAheadC :: Parser String
361 lookAheadC = liftM joinLines lookAhead
364 joinLines ('\\':'\n':s) = joinLines s
365 joinLines (c:s) = c : joinLines s
367 satisfyC :: (Char -> Bool) -> Parser Char
371 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
374 charC_ :: Char -> Parser ()
376 satisfyC (== c) `message` (show c++" expected")
379 anyCharC_ :: Parser ()
381 satisfyC (const True) `message` "Unexpected end of file"
384 any2CharsC_ :: Parser ()
385 any2CharsC_ = anyCharC_ >> anyCharC_
387 manySatisfyC :: (Char -> Bool) -> Parser String
388 manySatisfyC = many . satisfyC
390 manySatisfyC_ :: (Char -> Bool) -> Parser ()
391 manySatisfyC_ = many_ . satisfyC
393 special :: Parser Token
395 manySatisfyC_ (\c -> isSpace c && c /= '\n')
400 manySatisfyC_ isSpace
401 sp <- keyArg (== '\n')
404 _ -> keyArg (const False)
406 keyArg :: (Char -> Bool) -> Parser Token
409 key <- keyword `message` "hsc keyword or '{' expected"
410 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
411 arg <- catchOutput_ (argument eol)
412 return (Special pos key arg)
414 keyword :: Parser String
416 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
417 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
420 argument :: (Char -> Bool) -> Parser ()
425 c:_ | eol c -> do anyCharC_; argument eol
427 '\"':_ -> do anyCharC_; cString '\"'; argument eol
428 '\'':_ -> do anyCharC_; cString '\''; argument eol
429 '(':_ -> do anyCharC_; nested ')'; argument eol
431 '/':'*':_ -> do any2CharsC_; cComment; argument eol
433 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
434 '[':_ -> do anyCharC_; nested ']'; argument eol
436 '{':_ -> do anyCharC_; nested '}'; argument eol
438 _:_ -> do anyCharC_; argument eol
440 nested :: Char -> Parser ()
441 nested c = do argument (== '\n'); charC_ c
443 cComment :: Parser ()
448 '*':'/':_ -> do any2CharsC_
449 _:_ -> do anyCharC_; cComment
451 cString :: Char -> Parser ()
456 c:_ | c == quote -> anyCharC_
457 '\\':_:_ -> do any2CharsC_; cString quote
458 _:_ -> do anyCharC_; cString quote
460 ------------------------------------------------------------------------
461 -- Write the output files.
463 splitName :: String -> (String, String)
465 case break (== '/') name of
466 (file, []) -> ([], file)
467 (dir, sep:rest) -> (dir++sep:restDir, restFile)
469 (restDir, restFile) = splitName rest
471 splitExt :: String -> (String, String)
473 case break (== '.') name of
474 (base, []) -> (base, [])
475 (base, sepRest@(sep:rest))
476 | null restExt -> (base, sepRest)
477 | otherwise -> (base++sep:restBase, restExt)
479 (restBase, restExt) = splitExt rest
481 output :: [Flag] -> String -> [Token] -> IO ()
482 output flags name toks = do
484 (outName, outDir, outBase) <- case [f | Output f <- flags] of
487 last ext == 'c' -> return (dir++base++init ext, dir, base)
488 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
489 | otherwise -> return (dir++base++".hs", dir, base)
491 (dir, file) = splitName name
492 (base, ext) = splitExt file
494 (dir, file) = splitName f
495 (base, _) = splitExt file
496 in return (f, dir, base)
497 _ -> onlyOne "output file"
499 let cProgName = outDir++outBase++"_hsc_make.c"
500 oProgName = outDir++outBase++"_hsc_make.o"
501 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
502 outHFile = outBase++"_hsc.h"
503 outHName = outDir++outHFile
504 outCName = outDir++outBase++"_hsc.c"
506 beVerbose = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags
509 | null outDir = '.':pathSep:progName
510 | otherwise = progName
512 let specials = [(pos, key, arg) | Special pos key arg <- toks]
514 let needsC = any (\(_, key, _) -> key == "def") specials
517 let includeGuard = map fixChar outHName
519 fixChar c | isAlphaNum c = toUpper c
522 -- try locating GHC..on Win32, look in the vicinity of hsc2hs.
524 mb <- getExecDir "bin/hsc2hs.exe"
526 Nothing -> return def
528 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
529 flg <- doesFileExist ghc_path
534 compiler <- case [c | Compiler c <- flags] of
535 [] -> locateGhc "ghc"
537 _ -> onlyOne "compiler"
539 linker <- case [l | Linker l <- flags] of
540 [] -> locateGhc compiler
542 _ -> onlyOne "linker"
544 writeFile cProgName $
545 concatMap outFlagHeaderCProg flags++
546 concatMap outHeaderCProg specials++
547 "\nint main (int argc, char *argv [])\n{\n"++
548 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
549 outHsLine (SourcePos name 0)++
550 concatMap outTokenHs toks++
553 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
557 compilerStatus <- systemL beVerbose $
560 concat [" "++f | CompFlag f <- flags]++
563 case compilerStatus of
564 e@(ExitFailure _) -> exitWith e
568 linkerStatus <- systemL beVerbose $
570 concat [" "++f | LinkFlag f <- flags]++
574 e@(ExitFailure _) -> exitWith e
578 progStatus <- systemL beVerbose (execProgName++" >"++outName)
581 e@(ExitFailure _) -> exitWith e
584 when needsH $ writeFile outHName $
585 "#ifndef "++includeGuard++"\n\
586 \#define "++includeGuard++"\n\
588 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
591 \#include <HsFFI.h>\n\
594 \#define HsChar int\n\
596 concatMap outFlagH flags++
597 concatMap outTokenH specials++
600 when needsC $ writeFile outCName $
601 "#include \""++outHFile++"\"\n"++
602 concatMap outTokenC specials
603 -- NB. outHFile not outHName; works better when processed
604 -- by gcc or mkdependC.
606 systemL :: Bool -> String -> IO ExitCode
608 when flg (hPutStrLn stderr ("Executing: " ++ s))
611 onlyOne :: String -> IO a
612 onlyOne what = die ("Only one "++what++" may be specified\n")
614 outFlagHeaderCProg :: Flag -> String
615 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
616 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
617 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
618 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
619 outFlagHeaderCProg _ = ""
621 outHeaderCProg :: (SourcePos, String, String) -> String
622 outHeaderCProg (pos, key, arg) = case key of
623 "include" -> outCLine pos++"#include "++arg++"\n"
624 "define" -> outCLine pos++"#define "++arg++"\n"
625 "undef" -> outCLine pos++"#undef "++arg++"\n"
627 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
628 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
630 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
631 "let" -> case break (== '=') arg of
633 (header, _:body) -> case break isSpace header of
636 "#define hsc_"++name++"("++dropWhile isSpace args++") \
637 \printf ("++joinLines body++");\n"
640 joinLines = concat . intersperse " \\\n" . lines
642 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
643 outHeaderHs flags inH toks =
645 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
646 \ printf (\"{-# OPTIONS -optc-D" ++
647 "__GLASGOW_HASKELL__=%d #-}\\n\", \
648 \__GLASGOW_HASKELL__);\n\
651 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
652 Just f -> outOption ("-#include \""++f++"\"")
654 outFlag (Include f) = outOption ("-#include "++f)
655 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
656 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
658 outSpecial (pos, key, arg) = case key of
659 "include" -> outOption ("-#include "++arg)
660 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
662 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
664 goodForOptD arg = case arg of
666 c:_ | isSpace c -> True
669 toOptD arg = case break isSpace arg of
671 (name, _:value) -> name++'=':dropWhile isSpace value
672 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
673 showCString s++"\");\n"
675 outTokenHs :: Token -> String
676 outTokenHs (Text pos text) =
677 case break (== '\n') text of
678 (all, []) -> outText all
680 outText (first++"\n")++
684 outText s = " fputs (\""++showCString s++"\", stdout);\n"
685 outTokenHs (Special pos key arg) =
691 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
693 "enum" -> outCLine pos++outEnum arg
694 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
696 outEnum :: String -> String
698 case break (== ',') arg of
700 (t, _:afterT) -> case break (== ',') afterT of
703 enums (_:s) = case break (== ',') s of
705 this = case break (== '=') $ dropWhile isSpace enum of
707 " hsc_enum ("++t++", "++f++", \
708 \hsc_haskellize (\""++name++"\"), "++
711 " hsc_enum ("++t++", "++f++", \
712 \printf (\"%s\", \""++hsName++"\"), "++
717 outFlagH :: Flag -> String
718 outFlagH (Include f) = "#include "++f++"\n"
719 outFlagH (Define n Nothing) = "#define "++n++"\n"
720 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
723 outTokenH :: (SourcePos, String, String) -> String
724 outTokenH (pos, key, arg) =
726 "include" -> outCLine pos++"#include "++arg++"\n"
727 "define" -> outCLine pos++"#define " ++arg++"\n"
728 "undef" -> outCLine pos++"#undef " ++arg++"\n"
729 "def" -> outCLine pos++case arg of
730 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
731 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
732 'i':'n':'l':'i':'n':'e':' ':_ ->
737 _ -> "extern "++header++";\n"
738 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
739 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
742 outTokenC :: (SourcePos, String, String) -> String
743 outTokenC (pos, key, arg) =
746 's':'t':'r':'u':'c':'t':' ':_ -> ""
747 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
748 'i':'n':'l':'i':'n':'e':' ':arg' ->
749 case span (\c -> c /= '{' && c /= '=') arg' of
756 "\n#ifndef __GNUC__\n\
761 _ -> outCLine pos++arg++"\n"
762 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
765 conditional :: String -> Bool
766 conditional "if" = True
767 conditional "ifdef" = True
768 conditional "ifndef" = True
769 conditional "elif" = True
770 conditional "else" = True
771 conditional "endif" = True
772 conditional "error" = True
773 conditional "warning" = True
774 conditional _ = False
776 outCLine :: SourcePos -> String
777 outCLine (SourcePos name line) =
778 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
780 outHsLine :: SourcePos -> String
781 outHsLine (SourcePos name line) =
782 " hsc_line ("++show (line + 1)++", \""++
783 showCString (snd (splitName name))++"\");\n"
785 showCString :: String -> String
786 showCString = concatMap showCChar
788 showCChar '\"' = "\\\""
789 showCChar '\'' = "\\\'"
790 showCChar '?' = "\\?"
791 showCChar '\\' = "\\\\"
792 showCChar c | c >= ' ' && c <= '~' = [c]
793 showCChar '\a' = "\\a"
794 showCChar '\b' = "\\b"
795 showCChar '\f' = "\\f"
796 showCChar '\n' = "\\n\"\n \""
797 showCChar '\r' = "\\r"
798 showCChar '\t' = "\\t"
799 showCChar '\v' = "\\v"
801 intToDigit (ord c `quot` 64),
802 intToDigit (ord c `quot` 8 `mod` 8),
803 intToDigit (ord c `mod` 8)]
807 -----------------------------------------
808 -- Cut and pasted from ghc/compiler/SysTools
809 -- Convert paths foo/baz to foo\baz on Windows
812 #if defined(mingw32_HOST_OS)
813 subst a b ls = map (\ x -> if x == a then b else x) ls
814 unDosifyPath xs = subst '\\' '/' xs
815 dosifyPath xs = subst '/' '\\' xs
817 getExecDir :: String -> IO (Maybe String)
818 -- (getExecDir cmd) returns the directory in which the current
819 -- executable, which should be called 'cmd', is running
820 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
821 -- you'll get "/a/b/c" back as the result
823 = allocaArray len $ \buf -> do
824 ret <- getModuleFileName nullPtr buf len
825 if ret == 0 then return Nothing
826 else do s <- peekCString buf
827 return (Just (reverse (drop (length cmd)
828 (reverse (unDosifyPath s)))))
830 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
832 foreign import stdcall "GetModuleFileNameA" unsafe
833 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
838 getExecDir :: String -> IO (Maybe String)
839 getExecDir s = do return Nothing