yet more fixes: Cygwin broke this time

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

diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs
index 4b39e4a..77b948f 100644 (file)
--- a/utils/hsc2hs/Main.hs
+++ b/utils/hsc2hs/Main.hs
@@ -13,7 +13,7 @@
 #include "../../includes/ghcconfig.h"
 #endif
 
 #include "../../includes/ghcconfig.h"
 #endif
 

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

 import System.Console.GetOpt
 #else
 import GetOpt
 import System.Console.GetOpt
 #else
 import GetOpt

@@ -24,9 +24,9 @@ import Directory     (removeFile,doesFileExist)
 import Monad         (MonadPlus(..), liftM, liftM2, when)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)
 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 IO            (hPutStr, hPutStrLn, stderr, bracket_)

 
 

-#if defined(mingw32_HOST_OS) && !__HUGS__
+#if defined(mingw32_HOST_OS)

 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String
 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String

@@ -35,7 +35,6 @@ import CString
 #endif
 #endif
 
 #endif
 #endif
 

-

 #if __GLASGOW_HASKELL__ >= 604
 import System.Process           ( runProcess, waitForProcess )
 import System.IO                ( openFile, IOMode(..), hClose )
 #if __GLASGOW_HASKELL__ >= 604
 import System.Process           ( runProcess, waitForProcess )
 import System.IO                ( openFile, IOMode(..), hClose )

@@ -43,16 +42,20 @@ import System.IO                ( openFile, IOMode(..), hClose )
 #endif
 
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 #endif
 
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)

-import Compat.RawSystem        ( rawSystem )
+#ifdef USING_COMPAT
+import Compat.RawSystem ( rawSystem )
+#else
+import System.Cmd       ( rawSystem )
+#endif

 #define HAVE_rawSystem
 #define HAVE_rawSystem

-#elif __HUGS__ || __NHC__ >= 117
+#elif __NHC__ >= 117

 import System.Cmd              ( rawSystem )
 #define HAVE_rawSystem
 #endif
 
 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
 -- we need system
 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
+#if __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600

 import System.Cmd              ( system )
 #else
 import System                   ( system )
 import System.Cmd              ( system )
 #else
 import System                   ( system )

@@ -118,7 +121,6 @@ options = [
         "display this help and exit",
     Option ['V'] ["version"]    (NoArg  Version)
         "output version information and exit" ]
         "display this help and exit",
     Option ['V'] ["version"]    (NoArg  Version)
         "output version information and exit" ]

-    

 
 main :: IO ()
 main = do
 
 main :: IO ()
 main = do

@@ -129,26 +131,22 @@ 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 or Hugs (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
        -- 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
+                  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
                              Just path -> do
                                let templ = path ++ "/template-hsc.h"
                                flg <- doesFileExist templ
                           add_opt <-
                            case mb_path of
                              Nothing   -> return id
                              Just path -> do
                                let templ = path ++ "/template-hsc.h"
                                flg <- doesFileExist templ

-                               if flg 
+                               if flg

                                 then return ((Template templ):)
                                 else return id
                                 then return ((Template templ):)
                                 else return id

-                          return (add_opt flags) 
+                          return (add_opt flags)

     case (files, errs) of
         (_, _)
             | any isHelp    flags_w_tpl -> bye (usageInfo header options)
     case (files, errs) of
         (_, _)
             | any isHelp    flags_w_tpl -> bye (usageInfo header options)

@@ -172,7 +170,7 @@ die :: String -> IO a
 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
 
 processFile :: [Flag] -> String -> IO ()
 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
 
 processFile :: [Flag] -> String -> IO ()

-processFile flags name 
+processFile flags name

   = do let file_name = dosifyPath name
        s <- readFile file_name
        case parser of
   = do let file_name = dosifyPath name
        s <- readFile file_name
        case parser of

@@ -505,7 +503,7 @@ splitExt name =
 
 output :: [Flag] -> String -> [Token] -> IO ()
 output flags name toks = do
 
 output :: [Flag] -> String -> [Token] -> IO ()
 output flags name toks = do

-    
+

     (outName, outDir, outBase) <- case [f | Output f <- flags] of
         [] -> if not (null ext) && last ext == 'c'
                  then return (dir++base++init ext,  dir, base)
     (outName, outDir, outBase) <- case [f | Output f <- flags] of
         [] -> if not (null ext) && last ext == 'c'
                  then return (dir++base++init ext,  dir, base)

@@ -521,7 +519,7 @@ output flags name toks = do
             (base, _)    = splitExt file
             in return (f, dir, base)
         _ -> onlyOne "output file"
             (base, _)    = splitExt file
             in return (f, dir, base)
         _ -> onlyOne "output file"

-    
+

     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"

@@ -533,34 +531,23 @@ output flags name toks = do
        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
 
     let execProgName
             | null outDir = dosifyPath ("./" ++ progName)
             | otherwise   = progName
        beVerbose    = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
 
     let execProgName
             | null outDir = dosifyPath ("./" ++ progName)
             | otherwise   = progName

-    
+

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

-    
+

     let needsC = any (\(_, key, _) -> key == "def") specials
         needsH = needsC
     let needsC = any (\(_, key, _) -> key == "def") specials
         needsH = needsC

-    
+

     let includeGuard = map fixChar outHName
             where
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 
     let includeGuard = map fixChar outHName
             where
             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

@@ -570,15 +557,15 @@ output flags name toks = do
              Just x  -> do
                 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
                 flg <- doesFileExist ghc_path
              Just x  -> do
                 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
                 flg <- doesFileExist ghc_path

-                if flg 
+                if flg

                  then return ghc_path
                  else return def
                  then return ghc_path
                  else return def

-    
-       -- On a Win32 installation we execute the hsc2hs binary directly, 
+
+       -- 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.
        --
        -- 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 
+       -- 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
        --
        -- (called plain hsc2hs in the installed tree), which will pass
        -- a suitable C compiler via --cc
        --

@@ -588,12 +575,11 @@ output flags name toks = do
         []  -> locateGhc "ghc"
         [c] -> return c
         _   -> onlyOne "compiler"
         []  -> locateGhc "ghc"
         [c] -> return c
         _   -> onlyOne "compiler"

-    
+

     linker <- case [l | Linker l <- flags] of
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"
     linker <- case [l | Linker l <- flags] of
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"

-#endif

 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++

@@ -603,43 +589,30 @@ output flags name toks = do
         outHsLine (SourcePos name 0)++
         concatMap outTokenHs toks++
         "    return 0;\n}\n"
         outHsLine (SourcePos name 0)++
         concatMap outTokenHs toks++
         "    return 0;\n}\n"

-    
+

     -- 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
 
     -- 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 <- rawSystemL beVerbose compiler
+    rawSystemL ("compiling " ++ cProgName) beVerbose compiler

        (  ["-c"]
         ++ [f | CompFlag f <- flags]
         ++ [cProgName]
         ++ ["-o", oProgName]
        )
        (  ["-c"]
         ++ [f | CompFlag f <- flags]
         ++ [cProgName]
         ++ ["-o", oProgName]
        )

+    finallyRemove cProgName $ do

 
 

-    case compilerStatus of
-        e@(ExitFailure _) -> exitWith e
-        _                 -> return ()
-    removeFile cProgName
-    
-    linkerStatus <- rawSystemL beVerbose linker
+    rawSystemL ("linking " ++ oProgName) beVerbose linker

         (  [f | LinkFlag f <- flags]
         ++ [oProgName]
         ++ ["-o", progName]
        )
         (  [f | LinkFlag f <- flags]
         ++ [oProgName]
         ++ ["-o", progName]
        )

+    finallyRemove oProgName $ do
+
+    rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
+    finallyRemove progName $ do

 
 

-    case linkerStatus of
-        e@(ExitFailure _) -> exitWith e
-        _                 -> return ()
-    removeFile oProgName
-    
-    progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName
-    removeFile progName
-    case progStatus of
-        e@(ExitFailure _) -> exitWith e
-        _                 -> return ()
-    

     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n" ++
         "#define "++includeGuard++"\n" ++
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n" ++
         "#define "++includeGuard++"\n" ++

@@ -654,37 +627,55 @@ output flags name toks = do
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"

-    
+

     when needsC $ writeFile outCName $
         "#include \""++outHFile++"\"\n"++
         concatMap outTokenC specials
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 
     when needsC $ writeFile outCName $
         "#include \""++outHFile++"\"\n"++
         concatMap outTokenC specials
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 

-rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode
-rawSystemL flg prog args = do
+rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
+rawSystemL action flg prog args = do

   let cmdLine = prog++" "++unwords args
   when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
 #ifndef HAVE_rawSystem
   let cmdLine = prog++" "++unwords args
   when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
 #ifndef HAVE_rawSystem

-  system cmdLine
+  exitStatus <- system cmdLine

 #else
 #else

-  rawSystem prog args
+  exitStatus <- rawSystem prog args

 #endif
 #endif

+  case exitStatus of
+    ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
+    _             -> return ()

 
 

-rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
-rawSystemWithStdOutL flg prog args outFile = do
+rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
+rawSystemWithStdOutL action flg prog args outFile = do

   let cmdLine = prog++" "++unwords args++" >"++outFile
   when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
 #ifndef HAVE_runProcess
   let cmdLine = prog++" "++unwords args++" >"++outFile
   when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
 #ifndef HAVE_runProcess

-  system cmdLine
+  exitStatus <- system cmdLine

 #else
   hOut <- openFile outFile WriteMode
   process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
 #else
   hOut <- openFile outFile WriteMode
   process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing

-  res <- waitForProcess process
+  exitStatus <- waitForProcess process

   hClose hOut
   hClose hOut

-  return res

 #endif
 #endif

-
+  case exitStatus of
+    ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
+    _             -> return ()
+
+
+-- delay the cleanup of generated files until the end; attempts to
+-- get around intermittent failure to delete files which has
+-- just been exec'ed by a sub-process (Win32 only.)
+finallyRemove :: FilePath -> IO a -> IO a
+finallyRemove fp act = 
+  bracket_ (return fp)
+           (const $ noisyRemove fp)
+           act
+ where
+  noisyRemove fpath =
+    catch (removeFile fpath)
+          (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))

 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")
 

@@ -893,8 +884,6 @@ showCString = concatMap showCChar
                       intToDigit (ord c `quot` 8 `mod` 8),
                       intToDigit (ord c          `mod` 8)]
 
                       intToDigit (ord c `quot` 8 `mod` 8),
                       intToDigit (ord c          `mod` 8)]
 

-
-

 -----------------------------------------
 -- Modified version from ghc/compiler/SysTools
 -- Convert paths foo/baz to foo\baz on Windows
 -----------------------------------------
 -- Modified version from ghc/compiler/SysTools
 -- Convert paths foo/baz to foo\baz on Windows

@@ -921,9 +910,7 @@ getExecDir cmd =
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)

-#if defined(__HUGS__)
-getExecPath = liftM Just getProgName
-#elif defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS)

 getExecPath =
      allocaArray len $ \buf -> do
          ret <- getModuleFileName nullPtr buf len
 getExecPath =
      allocaArray len $ \buf -> do
          ret <- getModuleFileName nullPtr buf len