making hpc live

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

diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs
index 5f1955d..a5bd774 100644 (file)
--- a/utils/hsc2hs/Main.hs
+++ b/utils/hsc2hs/Main.hs
@@ -24,7 +24,7 @@ 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)
 import Foreign
 
 #if defined(mingw32_HOST_OS)
 import Foreign

@@ -42,7 +42,11 @@ 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
 #elif __NHC__ >= 117
 import System.Cmd              ( rawSystem )
 #define HAVE_rawSystem
 #elif __NHC__ >= 117
 import System.Cmd              ( rawSystem )

@@ -129,7 +133,7 @@ main = do
        -- to find one by looking near the executable.  This only
        -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
        -- script which specifies an explicit template flag.
        -- to find one by looking near the executable.  This only
        -- 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
+    flags_w_tpl0 <- if any template_flag flags then

                        return flags
                   else
                        do mb_path <- getExecDir "/bin/hsc2hs.exe"
                        return flags
                   else
                        do mb_path <- getExecDir "/bin/hsc2hs.exe"

@@ -143,6 +147,12 @@ main = do
                                 then return ((Template templ):)
                                 else return id
                           return (add_opt flags)
                                 then return ((Template templ):)
                                 else return id
                           return (add_opt flags)

+
+    -- take only the last --template flag on the cmd line
+    let
+      (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
+      flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
+

     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)

@@ -597,17 +607,17 @@ output flags name toks = do
         ++ [cProgName]
         ++ ["-o", oProgName]
        )
         ++ [cProgName]
         ++ ["-o", oProgName]
        )

-    removeFile cProgName
+    finallyRemove cProgName $ do

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

-    removeFile oProgName
+    finallyRemove oProgName $ do

 
     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
 
     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName

-    removeFile progName
+    finallyRemove progName $ do

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

@@ -659,6 +669,19 @@ rawSystemWithStdOutL action flg prog args outFile = do
     ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
     _             -> return ()
 
     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")