1 {-# OPTIONS -fglasgow-exts #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.45 2003/02/11 04:32:06 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"
109 let templ = path ++ "/template-hsc.h"
110 flg <- doesFileExist templ
112 then return ((Template templ):)
114 return (add_opt flags)
115 case (files, errs) of
117 | any isHelp flags_w_tpl -> putStrLn (usageInfo header options)
118 | any isVersion flags_w_tpl -> putStrLn version
120 isHelp Help = True; isHelp _ = False
121 isVersion Version = True; isVersion _ = False
122 ([], []) -> putStrLn (prog++": No input files")
123 (files, []) -> mapM_ (processFile flags_w_tpl) files
124 (_, errs) -> do { mapM_ putStrLn errs ;
125 putStrLn (usageInfo header options) ;
128 processFile :: [Flag] -> String -> IO ()
129 processFile flags name
130 = do let file_name = dosifyPath name
131 s <- readFile file_name
133 Parser p -> case p (SourcePos file_name 1) s of
134 Success _ _ _ toks -> output flags file_name toks
135 Failure (SourcePos name' line) msg -> do
136 putStrLn (name'++":"++show line++": "++msg)
139 ------------------------------------------------------------------------
140 -- A deterministic parser which remembers the text which has been parsed.
142 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
144 data ParseResult a = Success !SourcePos String String a
145 | Failure !SourcePos String
147 data SourcePos = SourcePos String !Int
149 updatePos :: SourcePos -> Char -> SourcePos
150 updatePos pos@(SourcePos name line) ch = case ch of
151 '\n' -> SourcePos name (line + 1)
154 instance Monad Parser where
155 return a = Parser $ \pos s -> Success pos [] s a
157 Parser $ \pos s -> case m pos s of
158 Success pos' out1 s' a -> case k a of
159 Parser k' -> case k' pos' s' of
160 Success pos'' out2 imp'' b ->
161 Success pos'' (out1++out2) imp'' b
162 Failure pos'' msg -> Failure pos'' msg
163 Failure pos' msg -> Failure pos' msg
164 fail msg = Parser $ \pos _ -> Failure pos msg
166 instance MonadPlus Parser where
168 Parser m `mplus` Parser n =
169 Parser $ \pos s -> case m pos s of
170 success@(Success _ _ _ _) -> success
171 Failure _ _ -> n pos s
173 getPos :: Parser SourcePos
174 getPos = Parser $ \pos s -> Success pos [] s pos
176 setPos :: SourcePos -> Parser ()
177 setPos pos = Parser $ \_ s -> Success pos [] s ()
179 message :: Parser a -> String -> Parser a
180 Parser m `message` msg =
181 Parser $ \pos s -> case m pos s of
182 success@(Success _ _ _ _) -> success
183 Failure pos' _ -> Failure pos' msg
185 catchOutput_ :: Parser a -> Parser String
186 catchOutput_ (Parser m) =
187 Parser $ \pos s -> case m pos s of
188 Success pos' out s' _ -> Success pos' [] s' out
189 Failure pos' msg -> Failure pos' msg
191 fakeOutput :: Parser a -> String -> Parser a
192 Parser m `fakeOutput` out =
193 Parser $ \pos s -> case m pos s of
194 Success pos' _ s' a -> Success pos' out s' a
195 Failure pos' msg -> Failure pos' msg
197 lookAhead :: Parser String
198 lookAhead = Parser $ \pos s -> Success pos [] s s
200 satisfy :: (Char -> Bool) -> Parser Char
202 Parser $ \pos s -> case s of
203 c:cs | p c -> Success (updatePos pos c) [c] cs c
204 _ -> Failure pos "Bad character"
206 char_ :: Char -> Parser ()
208 satisfy (== c) `message` (show c++" expected")
211 anyChar_ :: Parser ()
213 satisfy (const True) `message` "Unexpected end of file"
216 any2Chars_ :: Parser ()
217 any2Chars_ = anyChar_ >> anyChar_
219 many :: Parser a -> Parser [a]
220 many p = many1 p `mplus` return []
222 many1 :: Parser a -> Parser [a]
223 many1 p = liftM2 (:) p (many p)
225 many_ :: Parser a -> Parser ()
226 many_ p = many1_ p `mplus` return ()
228 many1_ :: Parser a -> Parser ()
229 many1_ p = p >> many_ p
231 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
232 manySatisfy = many . satisfy
233 manySatisfy1 = many1 . satisfy
235 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
236 manySatisfy_ = many_ . satisfy
237 manySatisfy1_ = many1_ . satisfy
239 ------------------------------------------------------------------------
240 -- Parser of hsc syntax.
243 = Text SourcePos String
244 | Special SourcePos String String
246 parser :: Parser [Token]
249 t <- catchOutput_ text
253 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
254 return (if null t then rest else Text pos t : rest)
261 c:_ | isAlpha c || c == '_' -> do
263 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
265 c:_ | isHsSymbol c -> do
266 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
269 '-':'-':symb' | all (== '-') symb' -> do
270 return () `fakeOutput` symb
271 manySatisfy_ (/= '\n')
274 return () `fakeOutput` unescapeHashes symb
276 '\"':_ -> do anyChar_; hsString '\"'; text
277 '\'':_ -> do anyChar_; hsString '\''; text
278 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
279 _:_ -> do anyChar_; text
281 hsString :: Char -> Parser ()
286 c:_ | c == quote -> anyChar_
291 char_ '\\' `mplus` return ()
293 | otherwise -> do any2Chars_; hsString quote
294 _:_ -> do anyChar_; hsString quote
296 hsComment :: Parser ()
301 '-':'}':_ -> any2Chars_
302 '{':'-':_ -> do any2Chars_; hsComment; hsComment
303 _:_ -> do anyChar_; hsComment
305 linePragma :: Parser ()
309 satisfy (\c -> c == 'L' || c == 'l')
310 satisfy (\c -> c == 'I' || c == 'i')
311 satisfy (\c -> c == 'N' || c == 'n')
312 satisfy (\c -> c == 'E' || c == 'e')
313 manySatisfy1_ isSpace
314 line <- liftM read $ manySatisfy1 isDigit
315 manySatisfy1_ isSpace
317 name <- manySatisfy (/= '\"')
323 setPos (SourcePos name (line - 1))
325 isHsSymbol :: Char -> Bool
326 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
327 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
328 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
329 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
330 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
331 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
332 isHsSymbol '~' = True
335 unescapeHashes :: String -> String
336 unescapeHashes [] = []
337 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
338 unescapeHashes (c:s) = c : unescapeHashes s
340 lookAheadC :: Parser String
341 lookAheadC = liftM joinLines lookAhead
344 joinLines ('\\':'\n':s) = joinLines s
345 joinLines (c:s) = c : joinLines s
347 satisfyC :: (Char -> Bool) -> Parser Char
351 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
354 charC_ :: Char -> Parser ()
356 satisfyC (== c) `message` (show c++" expected")
359 anyCharC_ :: Parser ()
361 satisfyC (const True) `message` "Unexpected end of file"
364 any2CharsC_ :: Parser ()
365 any2CharsC_ = anyCharC_ >> anyCharC_
367 manySatisfyC :: (Char -> Bool) -> Parser String
368 manySatisfyC = many . satisfyC
370 manySatisfyC_ :: (Char -> Bool) -> Parser ()
371 manySatisfyC_ = many_ . satisfyC
373 special :: Parser Token
375 manySatisfyC_ (\c -> isSpace c && c /= '\n')
380 manySatisfyC_ isSpace
381 sp <- keyArg (== '\n')
384 _ -> keyArg (const False)
386 keyArg :: (Char -> Bool) -> Parser Token
389 key <- keyword `message` "hsc keyword or '{' expected"
390 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
391 arg <- catchOutput_ (argument eol)
392 return (Special pos key arg)
394 keyword :: Parser String
396 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
397 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
400 argument :: (Char -> Bool) -> Parser ()
405 c:_ | eol c -> do anyCharC_; argument eol
407 '\"':_ -> do anyCharC_; cString '\"'; argument eol
408 '\'':_ -> do anyCharC_; cString '\''; argument eol
409 '(':_ -> do anyCharC_; nested ')'; argument eol
411 '/':'*':_ -> do any2CharsC_; cComment; argument eol
413 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
414 '[':_ -> do anyCharC_; nested ']'; argument eol
416 '{':_ -> do anyCharC_; nested '}'; argument eol
418 _:_ -> do anyCharC_; argument eol
420 nested :: Char -> Parser ()
421 nested c = do argument (== '\n'); charC_ c
423 cComment :: Parser ()
428 '*':'/':_ -> do any2CharsC_
429 _:_ -> do anyCharC_; cComment
431 cString :: Char -> Parser ()
436 c:_ | c == quote -> anyCharC_
437 '\\':_:_ -> do any2CharsC_; cString quote
438 _:_ -> do anyCharC_; cString quote
440 ------------------------------------------------------------------------
441 -- Write the output files.
443 splitName :: String -> (String, String)
445 case break (== '/') name of
446 (file, []) -> ([], file)
447 (dir, sep:rest) -> (dir++sep:restDir, restFile)
449 (restDir, restFile) = splitName rest
451 splitExt :: String -> (String, String)
453 case break (== '.') name of
454 (base, []) -> (base, [])
455 (base, sepRest@(sep:rest))
456 | null restExt -> (base, sepRest)
457 | otherwise -> (base++sep:restBase, restExt)
459 (restBase, restExt) = splitExt rest
461 output :: [Flag] -> String -> [Token] -> IO ()
462 output flags name toks = do
464 (outName, outDir, outBase) <- case [f | Output f <- flags] of
467 last ext == 'c' -> return (dir++base++init ext, dir, base)
468 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
469 | otherwise -> return (dir++base++".hs", dir, base)
471 (dir, file) = splitName name
472 (base, ext) = splitExt file
474 (dir, file) = splitName f
475 (base, _) = splitExt file
476 in return (f, dir, base)
477 _ -> onlyOne "output file"
479 let cProgName = outDir++outBase++"_hsc_make.c"
480 oProgName = outDir++outBase++"_hsc_make.o"
481 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
482 outHFile = outBase++"_hsc.h"
483 outHName = outDir++outHFile
484 outCName = outDir++outBase++"_hsc.c"
486 beVerbose = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags
489 | null outDir = '.':pathSep:progName
490 | otherwise = progName
492 let specials = [(pos, key, arg) | Special pos key arg <- toks]
494 let needsC = any (\(_, key, _) -> key == "def") specials
497 let includeGuard = map fixChar outHName
499 fixChar c | isAlphaNum c = toUpper c
502 -- try locating GHC..on Win32, look in the vicinity of hsc2hs.
504 mb <- getExecDir "bin/hsc2hs.exe"
506 Nothing -> return def
508 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
509 flg <- doesFileExist ghc_path
514 compiler <- case [c | Compiler c <- flags] of
515 [] -> locateGhc "ghc"
517 _ -> onlyOne "compiler"
519 linker <- case [l | Linker l <- flags] of
520 [] -> locateGhc compiler
522 _ -> onlyOne "linker"
524 writeFile cProgName $
525 concatMap outFlagHeaderCProg flags++
526 concatMap outHeaderCProg specials++
527 "\nint main (void)\n{\n"++
528 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
529 outHsLine (SourcePos name 0)++
530 concatMap outTokenHs toks++
533 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
537 compilerStatus <- systemL beVerbose $
540 concat [" "++f | CompFlag f <- flags]++
543 case compilerStatus of
544 e@(ExitFailure _) -> exitWith e
548 linkerStatus <- systemL beVerbose $
550 concat [" "++f | LinkFlag f <- flags]++
554 e@(ExitFailure _) -> exitWith e
558 progStatus <- systemL beVerbose (execProgName++" >"++outName)
561 e@(ExitFailure _) -> exitWith e
564 when needsH $ writeFile outHName $
565 "#ifndef "++includeGuard++"\n\
566 \#define "++includeGuard++"\n\
568 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
571 \#include <HsFFI.h>\n\
574 \#define HsChar int\n\
576 concatMap outFlagH flags++
577 concatMap outTokenH specials++
580 when needsC $ writeFile outCName $
581 "#include \""++outHFile++"\"\n"++
582 concatMap outTokenC specials
583 -- NB. outHFile not outHName; works better when processed
584 -- by gcc or mkdependC.
586 systemL :: Bool -> String -> IO ExitCode
588 when flg (hPutStrLn stderr ("Executing: " ++ s))
591 onlyOne :: String -> IO a
593 putStrLn ("Only one "++what++" may be specified")
596 outFlagHeaderCProg :: Flag -> String
597 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
598 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
599 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
600 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
601 outFlagHeaderCProg _ = ""
603 outHeaderCProg :: (SourcePos, String, String) -> String
604 outHeaderCProg (pos, key, arg) = case key of
605 "include" -> outCLine pos++"#include "++arg++"\n"
606 "define" -> outCLine pos++"#define "++arg++"\n"
607 "undef" -> outCLine pos++"#undef "++arg++"\n"
609 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
610 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
612 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
613 "let" -> case break (== '=') arg of
615 (header, _:body) -> case break isSpace header of
618 "#define hsc_"++name++"("++dropWhile isSpace args++") \
619 \printf ("++joinLines body++");\n"
622 joinLines = concat . intersperse " \\\n" . lines
624 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
625 outHeaderHs flags inH toks =
627 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
628 \ printf (\"{-# OPTIONS -optc-D" ++
629 "__GLASGOW_HASKELL__=%d #-}\\n\", \
630 \__GLASGOW_HASKELL__);\n\
633 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
634 Just f -> outOption ("-#include \""++f++"\"")
636 outFlag (Include f) = outOption ("-#include "++f)
637 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
638 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
640 outSpecial (pos, key, arg) = case key of
641 "include" -> outOption ("-#include "++arg)
642 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
644 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
646 goodForOptD arg = case arg of
648 c:_ | isSpace c -> True
651 toOptD arg = case break isSpace arg of
653 (name, _:value) -> name++'=':dropWhile isSpace value
654 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
655 showCString s++"\");\n"
657 outTokenHs :: Token -> String
658 outTokenHs (Text pos text) =
659 case break (== '\n') text of
660 (all, []) -> outText all
662 outText (first++"\n")++
666 outText s = " fputs (\""++showCString s++"\", stdout);\n"
667 outTokenHs (Special pos key arg) =
673 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
675 "enum" -> outCLine pos++outEnum arg
676 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
678 outEnum :: String -> String
680 case break (== ',') arg of
682 (t, _:afterT) -> case break (== ',') afterT of
685 enums (_:s) = case break (== ',') s of
687 this = case break (== '=') $ dropWhile isSpace enum of
689 " hsc_enum ("++t++", "++f++", \
690 \hsc_haskellize (\""++name++"\"), "++
693 " hsc_enum ("++t++", "++f++", \
694 \printf (\"%s\", \""++hsName++"\"), "++
699 outFlagH :: Flag -> String
700 outFlagH (Include f) = "#include "++f++"\n"
701 outFlagH (Define n Nothing) = "#define "++n++"\n"
702 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
705 outTokenH :: (SourcePos, String, String) -> String
706 outTokenH (pos, key, arg) =
708 "include" -> outCLine pos++"#include "++arg++"\n"
709 "define" -> outCLine pos++"#define " ++arg++"\n"
710 "undef" -> outCLine pos++"#undef " ++arg++"\n"
711 "def" -> outCLine pos++case arg of
712 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
713 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
714 'i':'n':'l':'i':'n':'e':' ':_ ->
719 _ -> "extern "++header++";\n"
720 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
721 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
724 outTokenC :: (SourcePos, String, String) -> String
725 outTokenC (pos, key, arg) =
728 's':'t':'r':'u':'c':'t':' ':_ -> ""
729 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
730 'i':'n':'l':'i':'n':'e':' ':arg' ->
731 case span (\c -> c /= '{' && c /= '=') arg' of
738 "\n#ifndef __GNUC__\n\
743 _ -> outCLine pos++arg++"\n"
744 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
747 conditional :: String -> Bool
748 conditional "if" = True
749 conditional "ifdef" = True
750 conditional "ifndef" = True
751 conditional "elif" = True
752 conditional "else" = True
753 conditional "endif" = True
754 conditional "error" = True
755 conditional "warning" = True
756 conditional _ = False
758 outCLine :: SourcePos -> String
759 outCLine (SourcePos name line) =
760 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
762 outHsLine :: SourcePos -> String
763 outHsLine (SourcePos name line) =
764 " hsc_line ("++show (line + 1)++", \""++
765 showCString (snd (splitName name))++"\");\n"
767 showCString :: String -> String
768 showCString = concatMap showCChar
770 showCChar '\"' = "\\\""
771 showCChar '\'' = "\\\'"
772 showCChar '?' = "\\?"
773 showCChar '\\' = "\\\\"
774 showCChar c | c >= ' ' && c <= '~' = [c]
775 showCChar '\a' = "\\a"
776 showCChar '\b' = "\\b"
777 showCChar '\f' = "\\f"
778 showCChar '\n' = "\\n\"\n \""
779 showCChar '\r' = "\\r"
780 showCChar '\t' = "\\t"
781 showCChar '\v' = "\\v"
783 intToDigit (ord c `quot` 64),
784 intToDigit (ord c `quot` 8 `mod` 8),
785 intToDigit (ord c `mod` 8)]
789 -----------------------------------------
790 -- Cut and pasted from ghc/compiler/SysTools
791 -- Convert paths foo/baz to foo\baz on Windows
794 #if defined(mingw32_HOST_OS)
795 subst a b ls = map (\ x -> if x == a then b else x) ls
796 unDosifyPath xs = subst '\\' '/' xs
797 dosifyPath xs = subst '/' '\\' xs
799 getExecDir :: String -> IO (Maybe String)
800 -- (getExecDir cmd) returns the directory in which the current
801 -- executable, which should be called 'cmd', is running
802 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
803 -- you'll get "/a/b/c" back as the result
805 = allocaArray len $ \buf -> do
806 ret <- getModuleFileName nullPtr buf len
807 if ret == 0 then return Nothing
808 else do s <- peekCString buf
809 return (Just (reverse (drop (length cmd)
810 (reverse (unDosifyPath s)))))
812 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
814 foreign import stdcall unsafe "GetModuleFileNameA"
815 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
820 getExecDir :: String -> IO (Maybe String)
821 getExecDir s = do return Nothing