Comments only

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

diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs
index a36bc40..75ea57b 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 )

@@ -45,14 +44,14 @@ import System.IO                ( openFile, IOMode(..), hClose )
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 import Compat.RawSystem        ( rawSystem )
 #define HAVE_rawSystem
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 import Compat.RawSystem        ( 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 +117,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 +127,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 +166,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 +499,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 +515,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 +527,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 +553,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 +571,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,32 +585,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
 

-
-    

     rawSystemL ("compiling " ++ cProgName) beVerbose compiler
        (  ["-c"]
         ++ [f | CompFlag f <- flags]
         ++ [cProgName]
         ++ ["-o", oProgName]
        )
     rawSystemL ("compiling " ++ cProgName) beVerbose compiler
        (  ["-c"]
         ++ [f | CompFlag f <- flags]
         ++ [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" ++
         "#define "++includeGuard++"\n" ++
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n" ++
         "#define "++includeGuard++"\n" ++

@@ -643,7 +623,7 @@ 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
     when needsC $ writeFile outCName $
         "#include \""++outHFile++"\"\n"++
         concatMap outTokenC specials

@@ -679,6 +659,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")
 

@@ -887,8 +880,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

@@ -915,9 +906,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