projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Simon's big boxy-type commit
[ghc-hetmet.git] / ghc / utils / hsc2hs / Main.hs
diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index dd7833f..4b39e4a 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,8 +1,6 @@
-{-# OPTIONS -fffi #-}
+{-# OPTIONS -fffi -cpp #-}
 
 ------------------------------------------------------------------------
 
 ------------------------------------------------------------------------
--- $Id: Main.hs,v 1.56 2004/06/11 11:14:58 malcolm Exp $
---
 -- Program for converting .hsc files to .hs files, by converting the
 -- file into a C program which is run to generate the Haskell source.
 -- Certain items known only to the C compiler can then be used in
 -- Program for converting .hsc files to .hs files, by converting the
 -- file into a C program which is run to generate the Haskell source.
 -- Certain items known only to the C compiler can then be used in
@@ -11,20 +9,24 @@
 --
 -- See the documentation in the Users' Guide for more details.
 
 --
 -- See the documentation in the Users' Guide for more details.
 
-#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
+#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
+#include "../../includes/ghcconfig.h"
+#endif
+
+#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
 import System.Console.GetOpt
 #else
 import GetOpt
 #endif
 
 import System.Console.GetOpt
 #else
 import GetOpt
 #endif
 
-import System        (getProgName, getArgs, ExitCode(..), exitWith, system)
+import System        (getProgName, getArgs, ExitCode(..), exitWith)
 import Directory     (removeFile,doesFileExist)
 import Directory     (removeFile,doesFileExist)
-import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
+import Monad         (MonadPlus(..), liftM, liftM2, when)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)
 import IO            (hPutStr, hPutStrLn, stderr)
 
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)
 import IO            (hPutStr, hPutStrLn, stderr)
 
-#if defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS) && !__HUGS__
 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String
 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String
@@ -34,6 +36,29 @@ import CString
 #endif
 
 
 #endif
 
 
+#if __GLASGOW_HASKELL__ >= 604
+import System.Process           ( runProcess, waitForProcess )
+import System.IO                ( openFile, IOMode(..), hClose )
+#define HAVE_runProcess
+#endif
+
+#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
+import Compat.RawSystem        ( rawSystem )
+#define HAVE_rawSystem
+#elif __HUGS__ || __NHC__ >= 117
+import System.Cmd              ( rawSystem )
+#define HAVE_rawSystem
+#endif
+
+#if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
+-- we need system
+#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
+import System.Cmd              ( system )
+#else
+import System                   ( system )
+#endif
+#endif
+
 version :: String
 version = "hsc2hs version 0.66\n"
 
 version :: String
 version = "hsc2hs version 0.66\n"
 
@@ -104,12 +129,16 @@ main = do
 
        -- If there is no Template flag explicitly specified, try
        -- to find one by looking near the executable.  This only
 
        -- If there is no Template flag explicitly specified, try
        -- to find one by looking near the executable.  This only
-       -- works on Win32 (getExecDir). On Unix, there's a wrapper 
+       -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper 
        -- script which specifies an explicit template flag.
     flags_w_tpl <- if any template_flag flags then
                        return flags
                   else 
        -- script which specifies an explicit template flag.
     flags_w_tpl <- if any template_flag flags then
                        return flags
                   else 
+#ifdef __HUGS__
+                       do mb_path <- getExecDir "/Main.hs"
+#else
                        do mb_path <- getExecDir "/bin/hsc2hs.exe"
                        do mb_path <- getExecDir "/bin/hsc2hs.exe"
+#endif
                           add_opt <-
                            case mb_path of
                              Nothing   -> return id
                           add_opt <-
                            case mb_path of
                              Nothing   -> return id
@@ -478,14 +507,15 @@ output :: [Flag] -> String -> [Token] -> IO ()
 output flags name toks = do
     
     (outName, outDir, outBase) <- case [f | Output f <- flags] of
 output flags name toks = do
     
     (outName, outDir, outBase) <- case [f | Output f <- flags] of
-        []
-            | not (null ext) &&
-              last ext == 'c'   -> return (dir++base++init ext,  dir, base)
-            | ext == ".hs"      -> return (dir++base++"_out.hs", dir, base)
-            | otherwise         -> return (dir++base++".hs",     dir, base)
-            where
-            (dir,  file) = splitName name
-            (base, ext)  = splitExt  file
+        [] -> if not (null ext) && last ext == 'c'
+                 then return (dir++base++init ext,  dir, base)
+                 else
+                    if ext == ".hs"
+                       then return (dir++base++"_out.hs", dir, base)
+                       else return (dir++base++".hs",     dir, base)
+              where
+               (dir,  file) = splitName name
+               (base, ext)  = splitExt  file
         [f] -> let
             (dir,  file) = splitName f
             (base, _)    = splitExt file
         [f] -> let
             (dir,  file) = splitName f
             (base, _)    = splitExt file
@@ -495,7 +525,7 @@ output flags name toks = do
     let cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"
         progName     = outDir++outBase++"_hsc_make"
     let cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"
         progName     = outDir++outBase++"_hsc_make"
-#if defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
 -- via GHC has changed a few times, so this seems to be the only way...  :-P * * *
                           ++ ".exe"
 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
 -- via GHC has changed a few times, so this seems to be the only way...  :-P * * *
                           ++ ".exe"
@@ -504,7 +534,7 @@ output flags name toks = do
         outHName     = outDir++outHFile
         outCName     = outDir++outBase++"_hsc.c"
        
         outHName     = outDir++outHFile
         outCName     = outDir++outBase++"_hsc.c"
        
-       beVerbose    = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags
+       beVerbose    = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
 
     let execProgName
             | null outDir = dosifyPath ("./" ++ progName)
 
     let execProgName
             | null outDir = dosifyPath ("./" ++ progName)
@@ -520,6 +550,17 @@ output flags name toks = do
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 
+#ifdef __HUGS__
+    compiler <- case [c | Compiler c <- flags] of
+        []  -> return "gcc"
+        [c] -> return c
+        _   -> onlyOne "compiler"
+    
+    linker <- case [l | Linker l <- flags] of
+        []  -> return compiler
+        [l] -> return l
+        _   -> onlyOne "linker"
+#else
         -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
        -- Returns a native-format path
         locateGhc def = do
         -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
        -- Returns a native-format path
         locateGhc def = do
@@ -552,6 +593,7 @@ output flags name toks = do
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"
+#endif
 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
@@ -562,49 +604,53 @@ output flags name toks = do
         concatMap outTokenHs toks++
         "    return 0;\n}\n"
     
         concatMap outTokenHs toks++
         "    return 0;\n}\n"
     
-    unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
+    -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
+    -- so we use something slightly more complicated.   :-P
+    when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
+       exitWith ExitSuccess
 
 
     
 
 
     
-    compilerStatus <- systemL beVerbose $
-        compiler++
-        " -c"++
-        concat [" "++f | CompFlag f <- flags]++
-        " "++cProgName++
-        " -o "++oProgName
+    compilerStatus <- rawSystemL beVerbose compiler
+       (  ["-c"]
+        ++ [f | CompFlag f <- flags]
+        ++ [cProgName]
+        ++ ["-o", oProgName]
+       )
+
     case compilerStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     removeFile cProgName
     
     case compilerStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     removeFile cProgName
     
-    linkerStatus <- systemL beVerbose $
-        linker++
-        concat [" "++f | LinkFlag f <- flags]++
-        " "++oProgName++
-        " -o "++progName
+    linkerStatus <- rawSystemL beVerbose linker
+        (  [f | LinkFlag f <- flags]
+        ++ [oProgName]
+        ++ ["-o", progName]
+       )
+
     case linkerStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     removeFile oProgName
     
     case linkerStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     removeFile oProgName
     
-    progStatus <- systemL beVerbose (execProgName++" >"++outName)
+    progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName
     removeFile progName
     case progStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     
     when needsH $ writeFile outHName $
     removeFile progName
     case progStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     
     when needsH $ writeFile outHName $
-        "#ifndef "++includeGuard++"\n\ 
-        \#define "++includeGuard++"\n\ 
-        \#if " ++
-       "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ 
-        \#include <Rts.h>\n\ 
-        \#endif\n\ 
-        \#include <HsFFI.h>\n\ 
-        \#if __NHC__\n\ 
-        \#undef HsChar\n\ 
-        \#define HsChar int\n\ 
-        \#endif\n"++
+        "#ifndef "++includeGuard++"\n" ++
+        "#define "++includeGuard++"\n" ++
+        "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
+        "#include <Rts.h>\n" ++
+        "#endif\n" ++
+        "#include <HsFFI.h>\n" ++
+        "#if __NHC__\n" ++
+        "#undef HsChar\n" ++
+        "#define HsChar int\n" ++
+        "#endif\n" ++
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"
@@ -615,10 +661,29 @@ output flags name toks = do
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 
-systemL :: Bool -> String -> IO ExitCode
-systemL flg s = do
-  when flg (hPutStrLn stderr ("Executing: " ++ s))
-  system s
+rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode
+rawSystemL flg prog args = do
+  let cmdLine = prog++" "++unwords args
+  when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
+#ifndef HAVE_rawSystem
+  system cmdLine
+#else
+  rawSystem prog args
+#endif
+
+rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
+rawSystemWithStdOutL flg prog args outFile = do
+  let cmdLine = prog++" "++unwords args++" >"++outFile
+  when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
+#ifndef HAVE_runProcess
+  system cmdLine
+#else
+  hOut <- openFile outFile WriteMode
+  process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
+  res <- waitForProcess process
+  hClose hOut
+  return res
+#endif
 
 onlyOne :: String -> IO a
 onlyOne what = die ("Only one "++what++" may be specified\n")
 
 onlyOne :: String -> IO a
 onlyOne what = die ("Only one "++what++" may be specified\n")
@@ -626,7 +691,7 @@ onlyOne what = die ("Only one "++what++" may be specified\n")
 outFlagHeaderCProg :: Flag -> String
 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 outFlagHeaderCProg :: Flag -> String
 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
-outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++"\n"
+outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++" 1\n"
 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 outFlagHeaderCProg _                     = ""
 
 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 outFlagHeaderCProg _                     = ""
 
@@ -645,30 +710,30 @@ outHeaderCProg (pos, key, arg) = case key of
         (header, _:body) -> case break isSpace header of
             (name, args) ->
                 outCLine pos++
         (header, _:body) -> case break isSpace header of
             (name, args) ->
                 outCLine pos++
-                "#define hsc_"++name++"("++dropWhile isSpace args++") \ 
-                \printf ("++joinLines body++");\n"
+                "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
+                "printf ("++joinLines body++");\n"
     _ -> ""
     _ -> ""
-    where
+   where
     joinLines = concat . intersperse " \\\n" . lines
 
 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 outHeaderHs flags inH toks =
     "#if " ++
     joinLines = concat . intersperse " \\\n" . lines
 
 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 outHeaderHs flags inH toks =
     "#if " ++
-    "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ 
-    \    printf (\"{-# OPTIONS -optc-D" ++
-    "__GLASGOW_HASKELL__=%d #-}\\n\", \ 
-    \__GLASGOW_HASKELL__);\n\ 
-    \#endif\n"++
+    "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
+    "    printf (\"{-# OPTIONS -optc-D" ++
+    "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
+    "__GLASGOW_HASKELL__);\n" ++
+    "#endif\n"++
     case inH of
         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
     case inH of
         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
-        Just f  -> outOption ("-#include \""++f++"\"")
+        Just f  -> outInclude ("\""++f++"\"")
     where
     where
-    outFlag (Include f)          = outOption ("-#include "++f)
+    outFlag (Include f)          = outInclude f
     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
     outFlag _                    = ""
     outSpecial (pos, key, arg) = case key of
     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
     outFlag _                    = ""
     outSpecial (pos, key, arg) = case key of
-        "include"                  -> outOption ("-#include "++arg)
+        "include"                  -> outInclude arg
         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
                  | otherwise       -> ""
         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
                  | otherwise       -> ""
         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
@@ -681,8 +746,22 @@ outHeaderHs flags inH toks =
     toOptD arg = case break isSpace arg of
         (name, "")      -> name
         (name, _:value) -> name++'=':dropWhile isSpace value
     toOptD arg = case break isSpace arg of
         (name, "")      -> name
         (name, _:value) -> name++'=':dropWhile isSpace value
-    outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
-                  showCString s++"\");\n"
+    outOption s =
+       "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
+       "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
+                  showCString s++"\");\n"++
+       "#else\n"++
+       "    printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
+                  showCString s++"\");\n"++
+       "#endif\n"
+    outInclude s =
+       "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
+       "    printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
+                  showCString s++"\");\n"++
+       "#else\n"++
+       "    printf (\"{-# INCLUDE %s #-}\\n\", \""++
+                  showCString s++"\");\n"++
+       "#endif\n"
 
 outTokenHs :: Token -> String
 outTokenHs (Text pos txt) =
 
 outTokenHs :: Token -> String
 outTokenHs (Text pos txt) =
@@ -716,19 +795,19 @@ outEnum arg =
                     (enum, rest) -> let
                         this = case break (== '=') $ dropWhile isSpace enum of
                             (name, []) ->
                     (enum, rest) -> let
                         this = case break (== '=') $ dropWhile isSpace enum of
                             (name, []) ->
-                                "    hsc_enum ("++t++", "++f++", \ 
-                                \hsc_haskellize (\""++name++"\"), "++
+                                "    hsc_enum ("++t++", "++f++", " ++
+                                "hsc_haskellize (\""++name++"\"), "++
                                 name++");\n"
                             (hsName, _:cName) ->
                                 name++");\n"
                             (hsName, _:cName) ->
-                                "    hsc_enum ("++t++", "++f++", \ 
-                                \printf (\"%s\", \""++hsName++"\"), "++
+                                "    hsc_enum ("++t++", "++f++", " ++
+                                "printf (\"%s\", \""++hsName++"\"), "++
                                 cName++");\n"
                         in this++enums rest
                 in enums afterF
 
 outFlagH :: Flag -> String
 outFlagH (Include  f)          = "#include "++f++"\n"
                                 cName++");\n"
                         in this++enums rest
                 in enums afterF
 
 outFlagH :: Flag -> String
 outFlagH (Include  f)          = "#include "++f++"\n"
-outFlagH (Define   n Nothing)  = "#define "++n++"\n"
+outFlagH (Define   n Nothing)  = "#define "++n++" 1\n"
 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 outFlagH _                     = ""
 
 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 outFlagH _                     = ""
 
@@ -742,12 +821,12 @@ outTokenH (pos, key, arg) =
             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
             'i':'n':'l':'i':'n':'e':' ':_ ->
             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
             'i':'n':'l':'i':'n':'e':' ':_ ->
-                "#ifdef __GNUC__\n\ 
-                \extern\n\ 
-                \#endif\n"++
+                "#ifdef __GNUC__\n" ++
+                "extern\n" ++
+                "#endif\n"++
                 arg++"\n"
             _ -> "extern "++header++";\n"
                 arg++"\n"
             _ -> "extern "++header++";\n"
-            where header = takeWhile (\c -> c /= '{' && c /= '=') arg
+          where header = takeWhile (\c -> c /= '{' && c /= '=') arg
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 
@@ -761,13 +840,13 @@ outTokenC (pos, key, arg) =
                case span (\c -> c /= '{' && c /= '=') arg' of
                (header, body) ->
                    outCLine pos++
                case span (\c -> c /= '{' && c /= '=') arg' of
                (header, body) ->
                    outCLine pos++
-                   "#ifndef __GNUC__\n\ 
-                   \extern inline\n\ 
-                   \#endif\n"++
+                   "#ifndef __GNUC__\n" ++
+                   "extern inline\n" ++
+                   "#endif\n"++
                    header++
                    header++
-                   "\n#ifndef __GNUC__\n\ 
-                   \;\n\ 
-                   \#else\n"++
+                   "\n#ifndef __GNUC__\n" ++
+                   ";\n" ++
+                   "#else\n"++
                    body++
                    "\n#endif\n"
             _ -> outCLine pos++arg++"\n"
                    body++
                    "\n#endif\n"
             _ -> outCLine pos++arg++"\n"
@@ -792,7 +871,7 @@ outCLine (SourcePos name line) =
 outHsLine :: SourcePos -> String
 outHsLine (SourcePos name line) =
     "    hsc_line ("++show (line + 1)++", \""++
 outHsLine :: SourcePos -> String
 outHsLine (SourcePos name line) =
     "    hsc_line ("++show (line + 1)++", \""++
-    showCString (snd (splitName name))++"\");\n"
+    showCString name++"\");\n"
 
 showCString :: String -> String
 showCString = concatMap showCChar
 
 showCString :: String -> String
 showCString = concatMap showCChar
@@ -817,40 +896,43 @@ showCString = concatMap showCChar
 
 
 -----------------------------------------
 
 
 -----------------------------------------
---     Cut and pasted from ghc/compiler/SysTools
+-- Modified version from ghc/compiler/SysTools
 -- Convert paths foo/baz to foo\baz on Windows
 
 -- Convert paths foo/baz to foo\baz on Windows
 
-dosifyPath :: String -> String
-#if defined(mingw32_HOST_OS)
-dosifyPath xs = subst '/' '\\' xs
-
-unDosifyPath :: String -> String
-unDosifyPath xs = subst '\\' '/' xs
+subst :: Char -> Char -> String -> String
+#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
+subst a b = map (\x -> if x == a then b else x)
+#else
+subst _ _ = id
+#endif
 
 
-subst :: Eq a => a -> a -> [a] -> [a]
-subst a b ls = map (\ x -> if x == a then b else x) ls
+dosifyPath :: String -> String
+dosifyPath = subst '/' '\\'
 
 
-getExecDir :: String -> IO (Maybe String)
 -- (getExecDir cmd) returns the directory in which the current
 --                 executable, which should be called 'cmd', is running
 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 -- you'll get "/a/b/c" back as the result
 -- (getExecDir cmd) returns the directory in which the current
 --                 executable, which should be called 'cmd', is running
 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 -- you'll get "/a/b/c" back as the result
-getExecDir cmd
-  = allocaArray len $ \buf -> do
-       ret <- getModuleFileName nullPtr buf len
-       if ret == 0 then return Nothing
-                   else do s <- peekCString buf
-                           return (Just (reverse (drop (length cmd) 
-                                                       (reverse (unDosifyPath s)))))
-  where
-    len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
+getExecDir :: String -> IO (Maybe String)
+getExecDir cmd =
+    getExecPath >>= maybe (return Nothing) removeCmdSuffix
+    where unDosifyPath = subst '\\' '/'
+          initN n = reverse . drop n . reverse
+          removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
+
+getExecPath :: IO (Maybe String)
+#if defined(__HUGS__)
+getExecPath = liftM Just getProgName
+#elif defined(mingw32_HOST_OS)
+getExecPath =
+     allocaArray len $ \buf -> do
+         ret <- getModuleFileName nullPtr buf len
+         if ret == 0 then return Nothing
+                    else liftM Just $ peekCString buf
+    where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
 
 foreign import stdcall unsafe "GetModuleFileNameA"
 
 foreign import stdcall unsafe "GetModuleFileNameA"
-  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+    getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 #else
 #else
-dosifyPath xs = xs
-
-getExecDir :: String -> IO (Maybe String) 
-getExecDir _ = return Nothing
+getExecPath = return Nothing
 #endif
 #endif
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)