X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=3490b6c18d98d84f8105405b9da8861061dd36ad;hb=47d37047e1f51f32184e7a3b6e68a22c2156ae32;hp=51f15636135b94b53c685914c99448e1c6cbcbda;hpb=04a0cea56816d1d9a2407c1c087bd864785aa44d;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 51f1563..3490b6c 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) @@ -1075,13 +1063,16 @@ checkConsistency verbosity my_flags = do let pkgs = allPackagesInStack db_stack checkPackage p = do - (_,es) <- runValidate $ checkPackageConfig p db_stack False True + (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True if null es - then return [] + then do when (not simple_output) $ do + _ <- reportValidateErrors [] ws "" Nothing + return () + return [] else do when (not simple_output) $ do reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":") - _ <- reportValidateErrors es " " Nothing + _ <- reportValidateErrors es ws " " Nothing return () return [p] @@ -1167,26 +1158,32 @@ writeNewConfig verbosity filename ipis = do -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. -type ValidateError = (Force,String) +type ValidateError = (Force,String) +type ValidateWarning = String -newtype Validate a = V { runValidate :: IO (a, [ValidateError]) } +newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } instance Monad Validate where - return a = V $ return (a, []) + return a = V $ return (a, [], []) m >>= k = V $ do - (a, es) <- runValidate m - (b, es') <- runValidate (k a) - return (b,es++es') + (a, es, ws) <- runValidate m + (b, es', ws') <- runValidate (k a) + return (b,es++es',ws++ws') verror :: Force -> String -> Validate () -verror f s = V (return ((),[(f,s)])) +verror f s = V (return ((),[(f,s)],[])) + +vwarn :: String -> Validate () +vwarn s = V (return ((),[],["Warning: " ++ s])) liftIO :: IO a -> Validate a -liftIO k = V (k >>= \a -> return (a,[])) +liftIO k = V (k >>= \a -> return (a,[],[])) -- returns False if we should die -reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool -reportValidateErrors es prefix mb_force = do +reportValidateErrors :: [ValidateError] -> [ValidateWarning] + -> String -> Maybe Force -> IO Bool +reportValidateErrors es ws prefix mb_force = do + mapM_ (warn . (prefix++)) ws oks <- mapM report es return (and oks) where @@ -1212,8 +1209,8 @@ validatePackageConfig :: InstalledPackageInfo -> Force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do - (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update - ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force) + (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update + ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) when (not ok) $ exitWith (ExitFailure 1) checkPackageConfig :: InstalledPackageInfo @@ -1227,9 +1224,9 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do checkDuplicates db_stack pkg update mapM_ (checkDep db_stack) (depends pkg) checkDuplicateDepends (depends pkg) - mapM_ (checkDir "import-dirs") (importDirs pkg) - mapM_ (checkDir "library-dirs") (libraryDirs pkg) - mapM_ (checkDir "include-dirs") (includeDirs pkg) + mapM_ (checkDir False "import-dirs") (importDirs pkg) + mapM_ (checkDir True "library-dirs") (libraryDirs pkg) + mapM_ (checkDir True "include-dirs") (includeDirs pkg) checkModules pkg mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? @@ -1282,15 +1279,22 @@ checkDuplicates db_stack pkg update = do " overlaps with: " ++ unwords (map display dups) -checkDir :: String -> String -> Validate () -checkDir thisfield d +checkDir :: Bool -> String -> String -> Validate () +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) $ - verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") + let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory" + in + if warn_only + then vwarn msg + else verror ForceFiles msg checkDep :: PackageDBStack -> InstalledPackageId -> Validate () checkDep db_stack pkgid @@ -1456,9 +1460,7 @@ dieOrForceAll ForceAll s = ignoreError s dieOrForceAll _other s = dieForcible s warn :: String -> IO () -warn s = do - hFlush stdout - hPutStrLn stderr s +warn = reportError ignoreError :: String -> IO () ignoreError s = reportError (s ++ " (ignoring)") @@ -1526,7 +1528,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 @@ -1538,13 +1540,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 @@ -1587,7 +1582,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 @@ -1597,7 +1592,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_ = "." @@ -1638,9 +1633,7 @@ openNewFile dir template = do oflags = rw_flags .|. o_EXCL -#if __GLASGOW_HASKELL__ < 611 withFilePath = withCString -#endif findTempName x = do fd <- withFilePath filepath $ \ f -> @@ -1656,11 +1649,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 @@ -1702,3 +1691,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