1 {-# OPTIONS -fglasgow-exts #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.44 2003/02/07 21:55:36 sof 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, exitFailure, 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)
26 import IO (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-0.65"
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 "t" ["template"] (ReqArg Template "FILE") "template file",
75 Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
76 Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use",
77 Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
78 Option "I" [] (ReqArg (CompFlag . ("-I"++))
79 "DIR") "passed to the C compiler",
80 Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
81 Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source",
82 Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source",
83 Option "o" ["output"] (ReqArg Output "FILE") "name of main output file",
84 Option "" ["help"] (NoArg Help) "display this help and exit",
85 Option "v" ["verbose"] (NoArg Verbose) "dump commands to stderr",
86 Option "" ["version"] (NoArg Version) "output version information and exit",
87 Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"]
93 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
95 let (flags, files, errs) = getOpt Permute options args
97 -- If there is no Template flag explicitly specified, try
98 -- to find one by looking near the executable. This only
99 -- works on Win32 (getExecDir). On Unix, there's a wrapper
100 -- script which specifies an explicit template flag.
101 flags_w_tpl <- if any template_flag flags then
104 do { mb_path <- getExecDir "/bin/hsc2hs.exe" ;
106 Nothing -> return flags
108 Just path -> return (Template (path ++ "/template-hsc.h") : flags) }
110 case (files, errs) of
112 | any isHelp flags_w_tpl -> putStrLn (usageInfo header options)
113 | any isVersion flags_w_tpl -> putStrLn version
115 isHelp Help = True; isHelp _ = False
116 isVersion Version = True; isVersion _ = False
117 ([], []) -> putStrLn (prog++": No input files")
118 (files, []) -> mapM_ (processFile flags_w_tpl) files
119 (_, errs) -> do { mapM_ putStrLn errs ;
120 putStrLn (usageInfo header options) ;
123 processFile :: [Flag] -> String -> IO ()
124 processFile flags name
125 = do let file_name = dosifyPath name
126 s <- readFile file_name
128 Parser p -> case p (SourcePos file_name 1) s of
129 Success _ _ _ toks -> output flags file_name toks
130 Failure (SourcePos name' line) msg -> do
131 putStrLn (name'++":"++show line++": "++msg)
134 ------------------------------------------------------------------------
135 -- A deterministic parser which remembers the text which has been parsed.
137 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
139 data ParseResult a = Success !SourcePos String String a
140 | Failure !SourcePos String
142 data SourcePos = SourcePos String !Int
144 updatePos :: SourcePos -> Char -> SourcePos
145 updatePos pos@(SourcePos name line) ch = case ch of
146 '\n' -> SourcePos name (line + 1)
149 instance Monad Parser where
150 return a = Parser $ \pos s -> Success pos [] s a
152 Parser $ \pos s -> case m pos s of
153 Success pos' out1 s' a -> case k a of
154 Parser k' -> case k' pos' s' of
155 Success pos'' out2 imp'' b ->
156 Success pos'' (out1++out2) imp'' b
157 Failure pos'' msg -> Failure pos'' msg
158 Failure pos' msg -> Failure pos' msg
159 fail msg = Parser $ \pos _ -> Failure pos msg
161 instance MonadPlus Parser where
163 Parser m `mplus` Parser n =
164 Parser $ \pos s -> case m pos s of
165 success@(Success _ _ _ _) -> success
166 Failure _ _ -> n pos s
168 getPos :: Parser SourcePos
169 getPos = Parser $ \pos s -> Success pos [] s pos
171 setPos :: SourcePos -> Parser ()
172 setPos pos = Parser $ \_ s -> Success pos [] s ()
174 message :: Parser a -> String -> Parser a
175 Parser m `message` msg =
176 Parser $ \pos s -> case m pos s of
177 success@(Success _ _ _ _) -> success
178 Failure pos' _ -> Failure pos' msg
180 catchOutput_ :: Parser a -> Parser String
181 catchOutput_ (Parser m) =
182 Parser $ \pos s -> case m pos s of
183 Success pos' out s' _ -> Success pos' [] s' out
184 Failure pos' msg -> Failure pos' msg
186 fakeOutput :: Parser a -> String -> Parser a
187 Parser m `fakeOutput` out =
188 Parser $ \pos s -> case m pos s of
189 Success pos' _ s' a -> Success pos' out s' a
190 Failure pos' msg -> Failure pos' msg
192 lookAhead :: Parser String
193 lookAhead = Parser $ \pos s -> Success pos [] s s
195 satisfy :: (Char -> Bool) -> Parser Char
197 Parser $ \pos s -> case s of
198 c:cs | p c -> Success (updatePos pos c) [c] cs c
199 _ -> Failure pos "Bad character"
201 char_ :: Char -> Parser ()
203 satisfy (== c) `message` (show c++" expected")
206 anyChar_ :: Parser ()
208 satisfy (const True) `message` "Unexpected end of file"
211 any2Chars_ :: Parser ()
212 any2Chars_ = anyChar_ >> anyChar_
214 many :: Parser a -> Parser [a]
215 many p = many1 p `mplus` return []
217 many1 :: Parser a -> Parser [a]
218 many1 p = liftM2 (:) p (many p)
220 many_ :: Parser a -> Parser ()
221 many_ p = many1_ p `mplus` return ()
223 many1_ :: Parser a -> Parser ()
224 many1_ p = p >> many_ p
226 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
227 manySatisfy = many . satisfy
228 manySatisfy1 = many1 . satisfy
230 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
231 manySatisfy_ = many_ . satisfy
232 manySatisfy1_ = many1_ . satisfy
234 ------------------------------------------------------------------------
235 -- Parser of hsc syntax.
238 = Text SourcePos String
239 | Special SourcePos String String
241 parser :: Parser [Token]
244 t <- catchOutput_ text
248 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
249 return (if null t then rest else Text pos t : rest)
256 c:_ | isAlpha c || c == '_' -> do
258 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
260 c:_ | isHsSymbol c -> do
261 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
264 '-':'-':symb' | all (== '-') symb' -> do
265 return () `fakeOutput` symb
266 manySatisfy_ (/= '\n')
269 return () `fakeOutput` unescapeHashes symb
271 '\"':_ -> do anyChar_; hsString '\"'; text
272 '\'':_ -> do anyChar_; hsString '\''; text
273 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
274 _:_ -> do anyChar_; text
276 hsString :: Char -> Parser ()
281 c:_ | c == quote -> anyChar_
286 char_ '\\' `mplus` return ()
288 | otherwise -> do any2Chars_; hsString quote
289 _:_ -> do anyChar_; hsString quote
291 hsComment :: Parser ()
296 '-':'}':_ -> any2Chars_
297 '{':'-':_ -> do any2Chars_; hsComment; hsComment
298 _:_ -> do anyChar_; hsComment
300 linePragma :: Parser ()
304 satisfy (\c -> c == 'L' || c == 'l')
305 satisfy (\c -> c == 'I' || c == 'i')
306 satisfy (\c -> c == 'N' || c == 'n')
307 satisfy (\c -> c == 'E' || c == 'e')
308 manySatisfy1_ isSpace
309 line <- liftM read $ manySatisfy1 isDigit
310 manySatisfy1_ isSpace
312 name <- manySatisfy (/= '\"')
318 setPos (SourcePos name (line - 1))
320 isHsSymbol :: Char -> Bool
321 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
322 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
323 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
324 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
325 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
326 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
327 isHsSymbol '~' = True
330 unescapeHashes :: String -> String
331 unescapeHashes [] = []
332 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
333 unescapeHashes (c:s) = c : unescapeHashes s
335 lookAheadC :: Parser String
336 lookAheadC = liftM joinLines lookAhead
339 joinLines ('\\':'\n':s) = joinLines s
340 joinLines (c:s) = c : joinLines s
342 satisfyC :: (Char -> Bool) -> Parser Char
346 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
349 charC_ :: Char -> Parser ()
351 satisfyC (== c) `message` (show c++" expected")
354 anyCharC_ :: Parser ()
356 satisfyC (const True) `message` "Unexpected end of file"
359 any2CharsC_ :: Parser ()
360 any2CharsC_ = anyCharC_ >> anyCharC_
362 manySatisfyC :: (Char -> Bool) -> Parser String
363 manySatisfyC = many . satisfyC
365 manySatisfyC_ :: (Char -> Bool) -> Parser ()
366 manySatisfyC_ = many_ . satisfyC
368 special :: Parser Token
370 manySatisfyC_ (\c -> isSpace c && c /= '\n')
375 manySatisfyC_ isSpace
376 sp <- keyArg (== '\n')
379 _ -> keyArg (const False)
381 keyArg :: (Char -> Bool) -> Parser Token
384 key <- keyword `message` "hsc keyword or '{' expected"
385 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
386 arg <- catchOutput_ (argument eol)
387 return (Special pos key arg)
389 keyword :: Parser String
391 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
392 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
395 argument :: (Char -> Bool) -> Parser ()
400 c:_ | eol c -> do anyCharC_; argument eol
402 '\"':_ -> do anyCharC_; cString '\"'; argument eol
403 '\'':_ -> do anyCharC_; cString '\''; argument eol
404 '(':_ -> do anyCharC_; nested ')'; argument eol
406 '/':'*':_ -> do any2CharsC_; cComment; argument eol
408 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
409 '[':_ -> do anyCharC_; nested ']'; argument eol
411 '{':_ -> do anyCharC_; nested '}'; argument eol
413 _:_ -> do anyCharC_; argument eol
415 nested :: Char -> Parser ()
416 nested c = do argument (== '\n'); charC_ c
418 cComment :: Parser ()
423 '*':'/':_ -> do any2CharsC_
424 _:_ -> do anyCharC_; cComment
426 cString :: Char -> Parser ()
431 c:_ | c == quote -> anyCharC_
432 '\\':_:_ -> do any2CharsC_; cString quote
433 _:_ -> do anyCharC_; cString quote
435 ------------------------------------------------------------------------
436 -- Write the output files.
438 splitName :: String -> (String, String)
440 case break (== '/') name of
441 (file, []) -> ([], file)
442 (dir, sep:rest) -> (dir++sep:restDir, restFile)
444 (restDir, restFile) = splitName rest
446 splitExt :: String -> (String, String)
448 case break (== '.') name of
449 (base, []) -> (base, [])
450 (base, sepRest@(sep:rest))
451 | null restExt -> (base, sepRest)
452 | otherwise -> (base++sep:restBase, restExt)
454 (restBase, restExt) = splitExt rest
456 output :: [Flag] -> String -> [Token] -> IO ()
457 output flags name toks = do
459 (outName, outDir, outBase) <- case [f | Output f <- flags] of
462 last ext == 'c' -> return (dir++base++init ext, dir, base)
463 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
464 | otherwise -> return (dir++base++".hs", dir, base)
466 (dir, file) = splitName name
467 (base, ext) = splitExt file
469 (dir, file) = splitName f
470 (base, _) = splitExt file
471 in return (f, dir, base)
472 _ -> onlyOne "output file"
474 let cProgName = outDir++outBase++"_hsc_make.c"
475 oProgName = outDir++outBase++"_hsc_make.o"
476 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
477 outHFile = outBase++"_hsc.h"
478 outHName = outDir++outHFile
479 outCName = outDir++outBase++"_hsc.c"
481 beVerbose = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags
484 | null outDir = '.':pathSep:progName
485 | otherwise = progName
487 let specials = [(pos, key, arg) | Special pos key arg <- toks]
489 let needsC = any (\(_, key, _) -> key == "def") specials
492 let includeGuard = map fixChar outHName
494 fixChar c | isAlphaNum c = toUpper c
497 -- try locating GHC..on Win32, look in the vicinity of hsc2hs.
499 mb <- getExecDir "bin/hsc2hs.exe"
501 Nothing -> return def
503 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
504 flg <- doesFileExist ghc_path
509 compiler <- case [c | Compiler c <- flags] of
510 [] -> locateGhc "ghc"
512 _ -> onlyOne "compiler"
514 linker <- case [l | Linker l <- flags] of
515 [] -> locateGhc "ghc"
517 _ -> onlyOne "linker"
519 writeFile cProgName $
520 concatMap outFlagHeaderCProg flags++
521 concatMap outHeaderCProg specials++
522 "\nint main (void)\n{\n"++
523 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
524 outHsLine (SourcePos name 0)++
525 concatMap outTokenHs toks++
528 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
532 compilerStatus <- systemL beVerbose $
535 concat [" "++f | CompFlag f <- flags]++
538 case compilerStatus of
539 e@(ExitFailure _) -> exitWith e
543 linkerStatus <- systemL beVerbose $
545 concat [" "++f | LinkFlag f <- flags]++
549 e@(ExitFailure _) -> exitWith e
553 progStatus <- systemL beVerbose (execProgName++" >"++outName)
556 e@(ExitFailure _) -> exitWith e
559 when needsH $ writeFile outHName $
560 "#ifndef "++includeGuard++"\n\
561 \#define "++includeGuard++"\n\
563 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
566 \#include <HsFFI.h>\n\
569 \#define HsChar int\n\
571 concatMap outFlagH flags++
572 concatMap outTokenH specials++
575 when needsC $ writeFile outCName $
576 "#include \""++outHFile++"\"\n"++
577 concatMap outTokenC specials
578 -- NB. outHFile not outHName; works better when processed
579 -- by gcc or mkdependC.
581 systemL :: Bool -> String -> IO ExitCode
583 when flg (hPutStrLn stderr ("Executing: " ++ s))
586 onlyOne :: String -> IO a
588 putStrLn ("Only one "++what++" may be specified")
591 outFlagHeaderCProg :: Flag -> String
592 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
593 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
594 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
595 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
596 outFlagHeaderCProg _ = ""
598 outHeaderCProg :: (SourcePos, String, String) -> String
599 outHeaderCProg (pos, key, arg) = case key of
600 "include" -> outCLine pos++"#include "++arg++"\n"
601 "define" -> outCLine pos++"#define "++arg++"\n"
602 "undef" -> outCLine pos++"#undef "++arg++"\n"
604 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
605 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
607 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
608 "let" -> case break (== '=') arg of
610 (header, _:body) -> case break isSpace header of
613 "#define hsc_"++name++"("++dropWhile isSpace args++") \
614 \printf ("++joinLines body++");\n"
617 joinLines = concat . intersperse " \\\n" . lines
619 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
620 outHeaderHs flags inH toks =
622 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
623 \ printf (\"{-# OPTIONS -optc-D" ++
624 "__GLASGOW_HASKELL__=%d #-}\\n\", \
625 \__GLASGOW_HASKELL__);\n\
628 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
629 Just f -> outOption ("-#include \""++f++"\"")
631 outFlag (Include f) = outOption ("-#include "++f)
632 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
633 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
635 outSpecial (pos, key, arg) = case key of
636 "include" -> outOption ("-#include "++arg)
637 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
639 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
641 goodForOptD arg = case arg of
643 c:_ | isSpace c -> True
646 toOptD arg = case break isSpace arg of
648 (name, _:value) -> name++'=':dropWhile isSpace value
649 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
650 showCString s++"\");\n"
652 outTokenHs :: Token -> String
653 outTokenHs (Text pos text) =
654 case break (== '\n') text of
655 (all, []) -> outText all
657 outText (first++"\n")++
661 outText s = " fputs (\""++showCString s++"\", stdout);\n"
662 outTokenHs (Special pos key arg) =
668 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
670 "enum" -> outCLine pos++outEnum arg
671 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
673 outEnum :: String -> String
675 case break (== ',') arg of
677 (t, _:afterT) -> case break (== ',') afterT of
680 enums (_:s) = case break (== ',') s of
682 this = case break (== '=') $ dropWhile isSpace enum of
684 " hsc_enum ("++t++", "++f++", \
685 \hsc_haskellize (\""++name++"\"), "++
688 " hsc_enum ("++t++", "++f++", \
689 \printf (\"%s\", \""++hsName++"\"), "++
694 outFlagH :: Flag -> String
695 outFlagH (Include f) = "#include "++f++"\n"
696 outFlagH (Define n Nothing) = "#define "++n++"\n"
697 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
700 outTokenH :: (SourcePos, String, String) -> String
701 outTokenH (pos, key, arg) =
703 "include" -> outCLine pos++"#include "++arg++"\n"
704 "define" -> outCLine pos++"#define " ++arg++"\n"
705 "undef" -> outCLine pos++"#undef " ++arg++"\n"
706 "def" -> outCLine pos++case arg of
707 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
708 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
709 'i':'n':'l':'i':'n':'e':' ':_ ->
714 _ -> "extern "++header++";\n"
715 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
716 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
719 outTokenC :: (SourcePos, String, String) -> String
720 outTokenC (pos, key, arg) =
723 's':'t':'r':'u':'c':'t':' ':_ -> ""
724 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
725 'i':'n':'l':'i':'n':'e':' ':arg' ->
726 case span (\c -> c /= '{' && c /= '=') arg' of
733 "\n#ifndef __GNUC__\n\
738 _ -> outCLine pos++arg++"\n"
739 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
742 conditional :: String -> Bool
743 conditional "if" = True
744 conditional "ifdef" = True
745 conditional "ifndef" = True
746 conditional "elif" = True
747 conditional "else" = True
748 conditional "endif" = True
749 conditional "error" = True
750 conditional "warning" = True
751 conditional _ = False
753 outCLine :: SourcePos -> String
754 outCLine (SourcePos name line) =
755 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
757 outHsLine :: SourcePos -> String
758 outHsLine (SourcePos name line) =
759 " hsc_line ("++show (line + 1)++", \""++
760 showCString (snd (splitName name))++"\");\n"
762 showCString :: String -> String
763 showCString = concatMap showCChar
765 showCChar '\"' = "\\\""
766 showCChar '\'' = "\\\'"
767 showCChar '?' = "\\?"
768 showCChar '\\' = "\\\\"
769 showCChar c | c >= ' ' && c <= '~' = [c]
770 showCChar '\a' = "\\a"
771 showCChar '\b' = "\\b"
772 showCChar '\f' = "\\f"
773 showCChar '\n' = "\\n\"\n \""
774 showCChar '\r' = "\\r"
775 showCChar '\t' = "\\t"
776 showCChar '\v' = "\\v"
778 intToDigit (ord c `quot` 64),
779 intToDigit (ord c `quot` 8 `mod` 8),
780 intToDigit (ord c `mod` 8)]
784 -----------------------------------------
785 -- Cut and pasted from ghc/compiler/SysTools
786 -- Convert paths foo/baz to foo\baz on Windows
789 #if defined(mingw32_HOST_OS)
790 subst a b ls = map (\ x -> if x == a then b else x) ls
791 unDosifyPath xs = subst '\\' '/' xs
792 dosifyPath xs = subst '/' '\\' xs
794 getExecDir :: String -> IO (Maybe String)
795 -- (getExecDir cmd) returns the directory in which the current
796 -- executable, which should be called 'cmd', is running
797 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
798 -- you'll get "/a/b/c" back as the result
800 = allocaArray len $ \buf -> do
801 ret <- getModuleFileName nullPtr buf len
802 if ret == 0 then return Nothing
803 else do s <- peekCString buf
804 return (Just (reverse (drop (length cmd)
805 (reverse (unDosifyPath s)))))
807 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
809 foreign import stdcall unsafe "GetModuleFileNameA"
810 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
815 getExecDir :: String -> IO (Maybe String)
816 getExecDir s = do return Nothing