[project @ 2001-06-02 09:45:51 by qrczak]

[ghc-hetmet.git] / ghc / compiler / main / DriverUtil.hs

diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index 3c255ce..210acdb 100644 (file)
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.18 2001/03/07 10:28:40 rrt Exp $
+-- $Id: DriverUtil.hs,v 1.23 2001/06/02 09:45:51 qrczak Exp $
 --
 -- Utils for the driver
 --
@@ -14,20 +14,23 @@ module DriverUtil where
 
 import Util
 import Panic
-import TmpFiles ( v_TmpDir )
 
 import IOExts
 import Exception
 import Dynamic
 import RegexString
 
+import Directory       ( getDirectoryContents )
 import IO
 import System
-import Directory ( removeFile )
 import List
 import Char
 import Monad
 
+#ifndef mingw32_TARGET_OS
+import Posix
+#endif
+
 -----------------------------------------------------------------------------
 -- Errors
 
@@ -68,6 +71,17 @@ getOptionsFromSource file
 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
 
 -----------------------------------------------------------------------------
+-- A version of getDirectoryContents that is non-fatal if the
+-- directory doesn't exist.
+
+softGetDirectoryContents d
+   = IO.catch (getDirectoryContents d)
+         (\_ -> do hPutStr stderr 
+                         ("WARNING: error while reading directory " ++ d)
+                   return []
+         )
+
+-----------------------------------------------------------------------------
 -- Utils
 
 unknownFlagErr :: String -> a
@@ -94,7 +108,13 @@ handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 handleDyn = flip catchDyn
 
 handle :: (Exception -> IO a) -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 501
 handle = flip Exception.catchAllIO
+#else
+handle h f = f `Exception.catch` \e -> case e of
+    ExitException _ -> throw e
+    _               -> h e
+#endif
 
 split :: Char -> String -> [String]
 split c s = case rest of
@@ -115,6 +135,9 @@ addNoDups var x = do
 splitFilename :: String -> (String,String)
 splitFilename f = split_longest_prefix f '.'
 
+getFileSuffix :: String -> String
+getFileSuffix f = drop_longest_prefix f '.'
+
 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 splitFilename3 :: String -> (String,String,String)
 splitFilename3 str
@@ -163,23 +186,55 @@ remove_spaces :: String -> String
 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 
 
--- system that works feasibly under Windows (i.e. passes the command line to sh,
--- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
-kludgedSystem cmd phase_name
- = do
-#ifndef mingw32_TARGET_OS
-   exit_code <- system cmd `catchAllIO` 
-                  (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ghcToolDir :: String
+prependToolDir :: String -> IO String
+#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
+ghcToolDir = unsafePerformIO $ do
+               bs <- getEnv "GHC_TOOLDIR" `IO.catch` (\ _ -> return "")
+               case bs of
+                 "" -> return bs
+                 ls -> 
+                   let
+                    term = last ls
+                    bs' 
+                     | term `elem` ['/', '\\'] = bs
+                     | otherwise = bs ++ ['/']
+                   in
+                   return bs'
+
+prependToolDir x = return (dosifyPath (ghcToolDir ++ x))
+#else
+ghcToolDir = ""
+prependToolDir x = return x
+#endif
+
+appendInstallDir :: String -> IO String
+appendInstallDir cmd = 
+  case ghcToolDir of
+    "" -> return cmd
+    _  -> return (unwords [cmd, '-':'B':ghcToolDir])
+
+-- convert filepath into MSDOS form.
+dosifyPath :: String -> String
+#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
+dosifyPath stuff = subst '/' '\\' real_stuff
+ where
+   -- fully convince myself that /cygdrive/ prefixes cannot
+   -- really appear here.
+  cygdrive_prefix = "/cygdrive/"
+
+  real_stuff
+    | "/cygdrive/" `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
+    | otherwise = stuff
+   
+  subst a b ls = map (\ x -> if x == a then b else x) ls
+#else
+dosifyPath x = x
+#endif
+
+#ifdef mingw32_TARGET_OS
+foreign import "_getpid" myGetProcessID :: IO Int 
 #else
-   pid <- myGetProcessID
-   tmp_dir <- readIORef v_TmpDir
-   let tmp = tmp_dir++"/sh"++show pid
-   h <- openFile tmp WriteMode
-   hPutStrLn h cmd
-   hClose h
-   exit_code <- system ("sh - " ++ tmp) `catchAllIO` 
-                  (\_ -> removeFile tmp >>
-                          throwDyn (PhaseFailed phase_name (ExitFailure 1)))
-   removeFile tmp
+myGetProcessID :: IO Int
+myGetProcessID = Posix.getProcessID
 #endif
-   return exit_code