Simon's big boxy-type commit

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

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index 420111a..4b39e4a 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,8 +1,6 @@
 {-# OPTIONS -fffi -cpp #-}
 
 ------------------------------------------------------------------------
 {-# OPTIONS -fffi -cpp #-}
 
 ------------------------------------------------------------------------

--- $Id: Main.hs,v 1.72 2005/03/10 17:58:42 malcolm Exp $
---

 -- Program for converting .hsc files to .hs files, by converting the
 -- file into a C program which is run to generate the Haskell source.
 -- Certain items known only to the C compiler can then be used in
 -- Program for converting .hsc files to .hs files, by converting the
 -- file into a C program which is run to generate the Haskell source.
 -- Certain items known only to the C compiler can then be used in

@@ -21,7 +19,7 @@ import System.Console.GetOpt
 import GetOpt
 #endif
 
 import GetOpt
 #endif
 

-import System        (getProgName, getArgs, ExitCode(..), exitWith, system)
+import System        (getProgName, getArgs, ExitCode(..), exitWith)

 import Directory     (removeFile,doesFileExist)
 import Monad         (MonadPlus(..), liftM, liftM2, when)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import Directory     (removeFile,doesFileExist)
 import Monad         (MonadPlus(..), liftM, liftM2, when)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)

@@ -38,12 +36,27 @@ import CString
 #endif
 
 
 #endif
 
 

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

 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 import Compat.RawSystem        ( rawSystem )
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 import Compat.RawSystem        ( rawSystem )

-#elif __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
+#define HAVE_rawSystem
+#elif __HUGS__ || __NHC__ >= 117

 import System.Cmd              ( rawSystem )
 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
+import System.Cmd              ( system )

 #else
 #else

-rawSystem prog args = system (prog++" "++unwords args)
+import System                   ( system )
+#endif

 #endif
 
 version :: String
 #endif
 
 version :: String

@@ -621,7 +634,7 @@ output flags name toks = do
         _                 -> return ()
     removeFile oProgName
     
         _                 -> return ()
     removeFile oProgName
     

-    progStatus <- systemL beVerbose (execProgName++" >"++outName)
+    progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName

     removeFile progName
     case progStatus of
         e@(ExitFailure _) -> exitWith e
     removeFile progName
     case progStatus of
         e@(ExitFailure _) -> exitWith e

@@ -648,15 +661,29 @@ output flags name toks = do
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 

-rawSystemL :: Bool -> String -> [String] -> IO ExitCode
+rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode

 rawSystemL flg prog args = do
 rawSystemL flg prog args = do

-  when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
+  let cmdLine = prog++" "++unwords args
+  when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
+#ifndef HAVE_rawSystem
+  system cmdLine
+#else

   rawSystem prog args
   rawSystem prog args

+#endif

 
 

-systemL :: Bool -> String -> IO ExitCode
-systemL flg s = do
-  when flg (hPutStrLn stderr ("Executing: " ++ s))
-  system s
+rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
+rawSystemWithStdOutL flg prog args outFile = do
+  let cmdLine = prog++" "++unwords args++" >"++outFile
+  when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
+#ifndef HAVE_runProcess
+  system cmdLine
+#else
+  hOut <- openFile outFile WriteMode
+  process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
+  res <- waitForProcess process
+  hClose hOut
+  return res
+#endif

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

@@ -844,7 +871,7 @@ outCLine (SourcePos name line) =
 outHsLine :: SourcePos -> String
 outHsLine (SourcePos name line) =
     "    hsc_line ("++show (line + 1)++", \""++
 outHsLine :: SourcePos -> String
 outHsLine (SourcePos name line) =
     "    hsc_line ("++show (line + 1)++", \""++

-    showCString (snd (splitName name))++"\");\n"
+    showCString name++"\");\n"

 
 showCString :: String -> String
 showCString = concatMap showCChar
 
 showCString :: String -> String
 showCString = concatMap showCChar

@@ -869,45 +896,43 @@ showCString = concatMap showCChar
 
 
 -----------------------------------------
 
 
 -----------------------------------------

---     Cut and pasted from ghc/compiler/SysTools
+-- Modified version from ghc/compiler/SysTools

 -- Convert paths foo/baz to foo\baz on Windows
 
 -- Convert paths foo/baz to foo\baz on Windows
 

-dosifyPath, unDosifyPath :: String -> String
+subst :: Char -> Char -> String -> String

 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)

-dosifyPath xs = subst '/' '\\' xs
-unDosifyPath xs = subst '\\' '/' xs
-
-subst :: Eq a => a -> a -> [a] -> [a]
-subst a b ls = map (\ x -> if x == a then b else x) ls
+subst a b = map (\x -> if x == a then b else x)

 #else
 #else

-dosifyPath xs = xs
-unDosifyPath xs = xs
+subst _ _ = id

 #endif
 
 #endif
 

-getExecDir :: String -> IO (Maybe String)
+dosifyPath :: String -> String
+dosifyPath = subst '/' '\\'
+

 -- (getExecDir cmd) returns the directory in which the current
 --                 executable, which should be called 'cmd', is running
 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 -- you'll get "/a/b/c" back as the result
 -- (getExecDir cmd) returns the directory in which the current
 --                 executable, which should be called 'cmd', is running
 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 -- you'll get "/a/b/c" back as the result

-#ifdef __HUGS__
-getExecDir cmd
-  = do
-       s <- getProgName
-       return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s)))))
+getExecDir :: String -> IO (Maybe String)
+getExecDir cmd =
+    getExecPath >>= maybe (return Nothing) removeCmdSuffix
+    where unDosifyPath = subst '\\' '/'
+          initN n = reverse . drop n . reverse
+          removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
+
+getExecPath :: IO (Maybe String)
+#if defined(__HUGS__)
+getExecPath = liftM Just getProgName

 #elif defined(mingw32_HOST_OS)
 #elif defined(mingw32_HOST_OS)

-getExecDir cmd
-  = allocaArray len $ \buf -> do
-       ret <- getModuleFileName nullPtr buf len
-       if ret == 0 then return Nothing
-                   else do s <- peekCString buf
-                           return (Just (reverse (drop (length cmd) 
-                                                       (reverse (unDosifyPath s)))))
-  where
-    len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
+getExecPath =
+     allocaArray len $ \buf -> do
+         ret <- getModuleFileName nullPtr buf len
+         if ret == 0 then return Nothing
+                    else liftM Just $ peekCString buf
+    where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.

 
 foreign import stdcall unsafe "GetModuleFileNameA"
 
 foreign import stdcall unsafe "GetModuleFileNameA"

-  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+    getModuleFileName :: Ptr () -> CString -> Int -> IO Int32

 #else
 #else

-getExecDir _ = return Nothing
+getExecPath = return Nothing

 #endif
 #endif