X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhsc2hs%2FMain.hs;h=b4229869678ed4b7b92f53230771322936d50a9e;hb=2ef4a7e8d1bed972c9be694ab04158c2c3142792;hp=9f202fd654d2044003e35fa495dc62217dd26d34;hpb=79e33ba981ddd0f5c9adb530e5c5f61b16c7a74a;p=ghc-hetmet.git

diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs
index 9f202fd..b422986 100644
--- a/utils/hsc2hs/Main.hs
+++ b/utils/hsc2hs/Main.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -fffi -cpp #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
 
 ------------------------------------------------------------------------
 -- Program for converting .hsc files to .hs files, by converting the
@@ -13,7 +13,7 @@
 #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
@@ -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 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
@@ -42,22 +42,25 @@ import System.IO                ( openFile, IOMode(..), hClose )
 #endif
 
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
-import Compat.RawSystem 	( rawSystem )
+import System.Cmd       ( 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
-#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
+#if __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
 import System.Cmd	 	( system )
 #else
 import System                   ( system )
 #endif
 #endif
 
+import Distribution.Text
+import qualified Paths_hsc2hs
+
 version :: String
 version = "hsc2hs version 0.66\n"
 
@@ -129,24 +132,29 @@ 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
-#ifdef __HUGS__
-			do mb_path <- getExecDir "/Main.hs"
-#else
 			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"
+                              -- Euch, this is horrible. Unfortunately
+                              -- Paths_hsc2hs isn't too useful for a
+                              -- relocatable binary, though.
+				let templ = path ++ "/hsc2hs-" ++ display Paths_hsc2hs.version ++ "/template-hsc.h"
 				flg <- doesFileExist templ
 				if flg
 				 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)
@@ -548,17 +556,6 @@ output flags name toks = do
             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
@@ -584,14 +581,11 @@ output flags name toks = do
 	-- (called hsc2hs-inplace, generated from hsc2hs.sh)
     compiler <- case [c | Compiler c <- flags] of
         []  -> locateGhc "ghc"
-        [c] -> return c
-        _   -> onlyOne "compiler"
+        cs  -> return (last cs)
 
     linker <- case [l | Linker l <- flags] of
         []  -> locateGhc compiler
-        [l] -> return l
-        _   -> onlyOne "linker"
-#endif
+        ls  -> return (last ls)
 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
@@ -613,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" ++
@@ -675,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")
 
@@ -909,9 +916,7 @@ getExecDir cmd =
           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