[project @ 2001-05-28 03:31:19 by sof]

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

diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index 91fd3ca..8ddc416 100644 (file)
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.16 2000/12/20 15:44:01 rrt Exp $
+-- $Id: DriverUtil.hs,v 1.22 2001/05/28 03:31:19 sof Exp $
 --
 -- Utils for the driver
 --
@@ -20,13 +20,17 @@ 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
 
@@ -67,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
@@ -114,6 +129,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
@@ -162,22 +180,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
-   let tmp = "/tmp/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