X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=20a6a44be7e0a1891b9bc0613378b73b6727e591;hb=13b1fa907fd5d700167cc4da26668fb356d5ecfc;hp=03a547d4c14599a91d463fcff5d65f1d7d9c4331;hpb=9ec14a9e16a761774b60c31b35bd1ba36cb74f00;p=ghc-hetmet.git

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 03a547d..20a6a44 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow 2004-2009.
@@ -27,14 +27,8 @@ import Text.Printf
 
 import Prelude
 
-#include "../../includes/ghcconfig.h"
-
 import System.Console.GetOpt
-#if __GLASGOW_HASKELL__ >= 609
 import qualified Control.Exception as Exception
-#else
-import qualified Control.Exception.Extensible as Exception
-#endif
 import Data.Maybe
 
 import Data.Char ( isSpace, toLower )
@@ -44,7 +38,7 @@ import System.Directory ( doesDirectoryExist, getDirectoryContents,
 import System.Exit ( exitWith, ExitCode(..) )
 import System.Environment ( getArgs, getProgName, getEnv )
 import System.IO
-import System.IO.Error (try)
+import System.IO.Error
 import Data.List
 import Control.Concurrent
 
@@ -60,12 +54,8 @@ import Foreign.C
 
 #if __GLASGOW_HASKELL__ < 612
 import System.Posix.Internals
-#if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Handle.FD (fdToHandle)
-#else
 import GHC.Handle (fdToHandle)
 #endif
-#endif
 
 #ifdef mingw32_HOST_OS
 import GHC.ConsoleHandler
@@ -73,8 +63,6 @@ import GHC.ConsoleHandler
 import System.Posix hiding (fdToHandle)
 #endif
 
-import IO ( isPermissionError )
-
 #if defined(GLOB)
 import System.Process(runInteractiveCommand)
 import qualified System.Info(os)
@@ -729,7 +717,7 @@ changeDBDir verbosity cmds db = do
   do_cmd (RemovePackage p) = do
     let file = location db </> display (installedPackageId p) <.> "conf"
     when (verbosity > Normal) $ putStrLn ("removing " ++ file)
-    removeFile file
+    removeFileSafe file
   do_cmd (AddPackage p) = do
     let file = location db </> display (installedPackageId p) <.> "conf"
     when (verbosity > Normal) $ putStrLn ("writing " ++ file)
@@ -1296,6 +1284,9 @@ checkDir warn_only thisfield d
  | "$topdir"     `isPrefixOf` d = return ()
  | "$httptopdir" `isPrefixOf` d = return ()
         -- can't check these, because we don't know what $(http)topdir is
+ | isRelative d = verror ForceFiles $
+                     thisfield ++ ": " ++ d ++ " is a relative path"
+        -- relative paths don't make any sense; #4134
  | otherwise = do
    there <- liftIO $ doesDirectoryExist d
    when (not there) $
@@ -1329,7 +1320,7 @@ checkHSLib dirs auto_ghci_libs lib = do
   case m of
     Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
                                    " on library path")
-    Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
+    Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
 
 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
 doesFileExistOnPath file path = go path
@@ -1355,13 +1346,10 @@ checkModules pkg = do
       when (isNothing m) $
          verror ForceFiles ("file " ++ file ++ " is missing")
 
-checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
-checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
+checkGHCiLib :: String -> String -> String -> Bool -> IO ()
+checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
   | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
-  | otherwise  = do
-      m <- doesFileExistOnPath ghci_lib_file dirs
-      when (isNothing m && ghci_lib_file /= "HSrts.o") $
-        warn ("warning: can't find GHCi lib " ++ ghci_lib_file)
+  | otherwise  = return ()
  where
     ghci_lib_file = lib <.> "o"
 
@@ -1537,7 +1525,7 @@ installSignalHandlers = do
   _ <- installHandler sigQUIT (Catch interrupt) Nothing
   _ <- installHandler sigINT  (Catch interrupt) Nothing
   return ()
-#elif __GLASGOW_HASKELL__ >= 603
+#else
   -- GHC 6.3+ has support for console events on Windows
   -- NOTE: running GHCi under a bash shell for some reason requires
   -- you to press Ctrl-Break rather than Ctrl-C to provoke
@@ -1549,13 +1537,6 @@ installSignalHandlers = do
 
   _ <- installHandler (Catch sig_handler)
   return ()
-#else
-  return () -- nothing
-#endif
-
-#if __GLASGOW_HASKELL__ <= 604
-isInfixOf               :: (Eq a) => [a] -> [a] -> Bool
-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
 #endif
 
 #if mingw32_HOST_OS || mingw32_TARGET_OS
@@ -1598,7 +1579,7 @@ withFileAtomic targetFile write_content = do
         `catchIO` \err -> do
           exists <- doesFileExist targetFile
           if exists
-            then do removeFile targetFile
+            then do removeFileSafe targetFile
                     -- Big fat hairy race condition
                     renameFile newFile targetFile
                     -- If the removeFile succeeds and the renameFile fails
@@ -1608,7 +1589,7 @@ withFileAtomic targetFile write_content = do
       renameFile newFile targetFile
 #endif
    `Exception.onException` do hClose newHandle
-                              removeFile newFile
+                              removeFileSafe newFile
   where
     template = targetName <.> "tmp"
     targetDir | null targetDir_ = "."
@@ -1649,9 +1630,7 @@ openNewFile dir template = do
 
     oflags = rw_flags .|. o_EXCL
 
-#if __GLASGOW_HASKELL__ < 611
     withFilePath = withCString
-#endif
 
     findTempName x = do
       fd <- withFilePath filepath $ \ f ->
@@ -1667,11 +1646,7 @@ openNewFile dir template = do
          -- as any exceptions etc will only be able to report the
          -- fd currently
          h <-
-#if __GLASGOW_HASKELL__ >= 609
               fdToHandle fd
-#else
-              fdToHandle (fromIntegral fd)
-#endif
               `Exception.onException` c_close fd
          return (filepath, h)
       where
@@ -1713,3 +1688,9 @@ readUTF8File file = do
   hSetEncoding h utf8
 #endif
   hGetContents h
+
+-- removeFileSave doesn't throw an exceptions, if the file is already deleted
+removeFileSafe :: FilePath -> IO ()
+removeFileSafe fn =
+  removeFile fn `catch` \ e ->
+    when (not $ isDoesNotExistError e) $ ioError e