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 IO            (hPutStr, hPutStrLn, stderr)
+import IO            (hPutStr, hPutStrLn, stderr, bracket_)
 
 #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)
-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 )
@@ -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.
-    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"
@@ -143,6 +147,12 @@ main = do
                                 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)
@@ -597,17 +607,17 @@ output flags name toks = do
         ++ [cProgName]
         ++ ["-o", oProgName]
        )
-    removeFile cProgName
+    finallyRemove cProgName $ do
 
     rawSystemL ("linking " ++ oProgName) beVerbose linker
         (  [f | LinkFlag f <- flags]
         ++ [oProgName]
         ++ ["-o", progName]
        )
-    removeFile oProgName
+    finallyRemove oProgName $ do
 
     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
-    removeFile progName
+    finallyRemove progName $ do
 
     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 ()
 
+
+-- 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")