[project @ 2003-07-17 08:59:03 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / SysTools.lhs

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index f9138cd..576761b 100644 (file)
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -65,6 +65,7 @@ module SysTools (
 #include "HsVersions.h"
 
 import DriverUtil
+import DriverPhases     ( haskellish_user_src_file )
 import Config
 import Outputable
 import Panic           ( progName, GhcException(..) )
@@ -81,7 +82,7 @@ import IO             ( try, catch,
                          openFile, hPutChar, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
                          stderr )
 import Directory       ( doesFileExist, removeFile )
-import List             ( intersperse )
+import List             ( intersperse, partition )
 
 #include "../includes/config.h"
 
@@ -278,30 +279,21 @@ initSysTools minusB_args
          -- On Win32, consult GetTempPath() for a temp dir.
          --  => it first tries TMP, TEMP, then finally the
          --   Windows directory(!). The directory is in short-path
-         --   form and *does* have a trailing backslash.
+         --   form.
        ; IO.try (do
                let len = (2048::Int)
                buf  <- mallocArray len
                ret  <- getTempPath len buf
                tdir <-
                  if ret == 0 then do
-                     -- failed, consult TEMP.
+                     -- failed, consult TMPDIR.
                     free buf
-                    getEnv "TMP"
+                    getEnv "TMPDIR"
                   else do
                     s <- peekCString buf
                     free buf
                     return s
-               let
-                 -- strip the trailing backslash (awful, but 
-                 -- we only do this once).
-                 tmpdir =
-                   case last tdir of
-                     '/'  -> init tdir
-                     '\\' -> init tdir
-                     _   -> tdir
-               setTmpDir tmpdir
-               return ())
+               setTmpDir tdir)
 #endif
 
        -- Check that the package config exists
@@ -627,7 +619,36 @@ GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 \end{code}
 
 \begin{code}
-setTmpDir dir = writeIORef v_TmpDir dir
+setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
+    where
+#if !defined(mingw32_HOST_OS)
+     canonicalise p = normalisePath p
+#else
+       -- Canonicalisation of temp path under win32 is a bit more
+       -- involved: (a) strip trailing slash, 
+       --           (b) normalise slashes
+       --           (c) just in case, if there is a prefix /cygdrive/x/, change to x:
+       -- 
+     canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
+
+        -- if we're operating under cygwin, and TMP/TEMP is of
+       -- the form "/cygdrive/drive/path", translate this to
+       -- "drive:/path" (as GHC isn't a cygwin app and doesn't
+       -- understand /cygdrive paths.)
+     xltCygdrive path
+      | "/cygdrive/" `isPrefixOf` path = 
+         case drop (length "/cygdrive/") path of
+           drive:xs@('/':_) -> drive:':':xs
+           _ -> path
+      | otherwise = path
+
+        -- strip the trailing backslash (awful, but we only do this once).
+     removeTrailingSlash path = 
+       case last path of
+         '/'  -> init path
+         '\\' -> init path
+         _    -> path
+#endif
 
 cleanTempFiles :: Int -> IO ()
 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
@@ -661,10 +682,25 @@ addFilesToClean files = mapM_ (add v_FilesToClean) files
 
 removeTmpFiles :: Int -> [FilePath] -> IO ()
 removeTmpFiles verb fs
-  = traceCmd "Deleting temp files" 
-            ("Deleting: " ++ unwords fs)
-            (mapM_ rm fs)
+  = warnNon $
+    traceCmd "Deleting temp files" 
+            ("Deleting: " ++ unwords deletees)
+            (mapM_ rm deletees)
   where
+     -- Flat out refuse to delete files that are likely to be source input
+     -- files (is there a worse bug than having a compiler delete your source
+     -- files?)
+     -- 
+     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
+     -- the condition.
+    warnNon act
+     | null non_deletees = act
+     | otherwise         = do
+        hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
+       act
+
+    (non_deletees, deletees) = partition haskellish_user_src_file fs
+
     rm f = removeFile f `IO.catch` 
                (\_ignored -> 
                    when (verb >= 2) $
@@ -745,7 +781,7 @@ rawSystem cmd args =
             0  -> return ExitSuccess
             n  -> return (ExitFailure n)
 
-foreign import ccall unsafe "rawSystem"
+foreign import ccall "rawSystem" unsafe
   c_rawSystem :: CString -> Ptr CString -> IO Int
 
 #else
@@ -770,7 +806,7 @@ translate str = '"' : foldr escape "\"" str
        escape '\\' str = '\\' : '\\' : str
        escape c    str = c : str
 
-foreign import ccall unsafe "rawSystem"
+foreign import ccall "rawSystem" unsafe
   c_rawSystem :: CString -> IO Int
 
 #endif
@@ -797,12 +833,8 @@ interpreted a command line 'foo\baz' as 'foobaz'.
 -----------------------------------------------------------------------------
 -- Convert filepath into platform / MSDOS form.
 
--- platformPath does two things
--- a) change '/' to '\'
--- b) remove initial '/cygdrive/'
-
 normalisePath :: String -> String
--- Just change '\' to '/'
+-- Just changes '\' to '/'
 
 pgmPath :: String              -- Directory string in Unix format
        -> String               -- Program name with no directory separators