Make hsc2hs emit the full path name in {-# LINE #-} pagmas.

[ghc-hetmet.git] / ghc / utils / hsc2hs / Main.hs

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index f90a89c..4b39e4a 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,8 +1,6 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS -fffi -cpp #-}

 
 ------------------------------------------------------------------------
 
 ------------------------------------------------------------------------

--- $Id: Main.hs,v 1.49 2003/10/01 16:45:10 sof 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,26 +9,26 @@
 --
 -- See the documentation in the Users' Guide for more details.
 
 --
 -- See the documentation in the Users' Guide for more details.
 

-#if __GLASGOW_HASKELL__ >= 504
+#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 Config
-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)
 

-#include "../../includes/config.h"
-
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) && !__HUGS__

 import Foreign
 import Foreign

-
-#if __GLASGOW_HASKELL__ >= 504
+#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114

 import Foreign.C.String
 #else
 import CString
 import Foreign.C.String
 #else
 import CString

@@ -38,9 +36,31 @@ 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 :: String

-version = "hsc2hs version 0.65\n"
+version = "hsc2hs version 0.66\n"

 
 data Flag
     = Help
 
 data Flag
     = Help

@@ -56,6 +76,7 @@ data Flag
     | Output    String
     | Verbose
 
     | Output    String
     | Verbose
 

+template_flag :: Flag -> Bool

 template_flag (Template _) = True
 template_flag _                   = False
 
 template_flag (Template _) = True
 template_flag _                   = False
 

@@ -108,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

@@ -131,8 +156,8 @@ main = do
             where
             isHelp    Help    = True; isHelp    _ = False
             isVersion Version = True; isVersion _ = False
             where
             isHelp    Help    = True; isHelp    _ = False
             isVersion Version = True; isVersion _ = False

-        (files@(_:_), []) -> mapM_ (processFile flags_w_tpl) files
-        (_,   errs) -> die (concat errs ++ usageInfo header options)
+        ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
+        (_,     _ ) -> die (concat errs ++ usageInfo header options)

 
 getProgramName :: IO String
 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
 
 getProgramName :: IO String
 getProgramName = liftM (`withoutSuffix` "-bin") getProgName

@@ -482,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

@@ -498,15 +524,20 @@ output flags name toks = do
     
     let cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"
     
     let cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"

-        progName     = outDir++outBase++"_hsc_make" ++ progNameSuffix
+        progName     = outDir++outBase++"_hsc_make"
+#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"
+#endif

        outHFile     = outBase++"_hsc.h"
         outHName     = outDir++outHFile
         outCName     = outDir++outBase++"_hsc.c"
        
        outHFile     = outBase++"_hsc.h"
         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
 
     let execProgName

-            | null outDir = '.':pathSep:progName
+            | null outDir = dosifyPath ("./" ++ progName)

             | otherwise   = progName
     
     let specials = [(pos, key, arg) | Special pos key arg <- toks]
             | otherwise   = progName
     
     let specials = [(pos, key, arg) | Special pos key arg <- toks]

@@ -519,7 +550,19 @@ output flags name toks = do
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 

-          -- try locating GHC..on Win32, look in the vicinity of hsc2hs.
+#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
            mb <- getExecDir "bin/hsc2hs.exe"
            case mb of
         locateGhc def = do
            mb <- getExecDir "bin/hsc2hs.exe"
            case mb of

@@ -531,6 +574,16 @@ output flags name toks = do
                  then return ghc_path
                  else return def
     
                  then return ghc_path
                  else return def
     

+       -- On a Win32 installation we execute the hsc2hs binary directly, 
+       -- with no --cc flags, so we'll call locateGhc here, which will
+       -- succeed, via getExecDir.
+       --
+       -- On a Unix installation, we'll run the wrapper script hsc2hs.sh 
+       -- (called plain hsc2hs in the installed tree), which will pass
+       -- a suitable C compiler via --cc
+       --
+       -- The in-place installation always uses the wrapper script,
+       -- (called hsc2hs-inplace, generated from hsc2hs.sh)

     compiler <- case [c | Compiler c <- flags] of
         []  -> locateGhc "ghc"
         [c] -> return c
     compiler <- case [c | Compiler c <- flags] of
         []  -> locateGhc "ghc"
         [c] -> return c

@@ -540,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++

@@ -550,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"

@@ -603,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")

@@ -614,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 _                     = ""
 

@@ -633,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"

@@ -669,13 +746,27 @@ 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 :: Token -> String

-outTokenHs (Text pos text) =
-    case break (== '\n') text of
-        (all, [])       -> outText all
+outTokenHs (Text pos txt) =
+    case break (== '\n') txt of
+        (allTxt, [])       -> outText allTxt

         (first, _:rest) ->
             outText (first++"\n")++
             outHsLine pos++
         (first, _:rest) ->
             outText (first++"\n")++
             outHsLine pos++

@@ -704,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 _                     = ""
 

@@ -730,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"
         _ -> ""
 

@@ -749,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"

@@ -780,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

@@ -805,36 +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
 

+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

 
 

-#if defined(mingw32_HOST_OS)
-subst a b ls = map (\ x -> if x == a then b else x) ls
-unDosifyPath xs = subst '\\' '/' xs
-dosifyPath xs = subst '/' '\\' xs
+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.
-
-foreign import stdcall "GetModuleFileNameA" unsafe
-  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+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"
+    getModuleFileName :: Ptr () -> CString -> Int -> IO Int32

 #else
 #else

-dosifyPath xs = xs
-
-getExecDir :: String -> IO (Maybe String) 
-getExecDir s = do return Nothing
+getExecPath = return Nothing

 #endif
 #endif