projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix #4346 (INLINABLE pragma not behaving consistently)
[ghc-hetmet.git]
/
utils
/
ghc-pkg
/
Main.hs
diff --git
a/utils/ghc-pkg/Main.hs
b/utils/ghc-pkg/Main.hs
index
79404bc
..
3490b6c
100644
(file)
--- 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.
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2009.
@@
-27,14
+27,8
@@
import Text.Printf
import Prelude
import Prelude
-#include "../../includes/ghcconfig.h"
-
import System.Console.GetOpt
import System.Console.GetOpt
-#if __GLASGOW_HASKELL__ >= 609
import qualified Control.Exception as Exception
import qualified Control.Exception as Exception
-#else
-import qualified Control.Exception.Extensible as Exception
-#endif
import Data.Maybe
import Data.Char ( isSpace, toLower )
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.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
import Data.List
import Control.Concurrent
@@
-52,16
+46,16
@@
import qualified Data.ByteString.Lazy as B
import qualified Data.Binary as Bin
import qualified Data.Binary.Get as Bin
import qualified Data.Binary as Bin
import qualified Data.Binary.Get as Bin
-#if __GLASGOW_HASKELL__ < 612
+#if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS)
+-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
import Foreign
import Foreign.C
import Foreign
import Foreign.C
+#endif
+
+#if __GLASGOW_HASKELL__ < 612
import System.Posix.Internals
import System.Posix.Internals
-#if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Handle.FD (fdToHandle)
-#else
import GHC.Handle (fdToHandle)
#endif
import GHC.Handle (fdToHandle)
#endif
-#endif
#ifdef mingw32_HOST_OS
import GHC.ConsoleHandler
#ifdef mingw32_HOST_OS
import GHC.ConsoleHandler
@@
-69,8
+63,6
@@
import GHC.ConsoleHandler
import System.Posix hiding (fdToHandle)
#endif
import System.Posix hiding (fdToHandle)
#endif
-import IO ( isPermissionError )
-
#if defined(GLOB)
import System.Process(runInteractiveCommand)
import qualified System.Info(os)
#if defined(GLOB)
import System.Process(runInteractiveCommand)
import qualified System.Info(os)
@@
-568,7
+560,7
@@
readParseDatabase verbosity mb_user_conf use_cache path
case e_tcache of
Left ex -> do
when (verbosity > Normal) $
case e_tcache of
Left ex -> do
when (verbosity > Normal) $
- putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
+ warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
ignore_cache
Right tcache
| tcache >= tdir -> do
ignore_cache
Right tcache
| tcache >= tdir -> do
@@
-579,8
+571,8
@@
readParseDatabase verbosity mb_user_conf use_cache path
return PackageDB { location = path, packages = pkgs' }
| otherwise -> do
when (verbosity >= Normal) $ do
return PackageDB { location = path, packages = pkgs' }
| otherwise -> do
when (verbosity >= Normal) $ do
- putStrLn ("WARNING: cache is out of date: " ++ cache)
- putStrLn " use 'ghc-pkg recache' to fix."
+ warn ("WARNING: cache is out of date: " ++ cache)
+ warn " use 'ghc-pkg recache' to fix."
ignore_cache
where
ignore_cache = do
ignore_cache
where
ignore_cache = do
@@
-725,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)
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)
do_cmd (AddPackage p) = do
let file = location db </> display (installedPackageId p) <.> "conf"
when (verbosity > Normal) $ putStrLn ("writing " ++ file)
@@
-856,7
+848,7
@@
listPackages verbosity my_flags mPackageName mModuleName = do
when (not (null broken) && not simple_output && verbosity /= Silent) $ do
prog <- getProgramName
when (not (null broken) && not simple_output && verbosity /= Silent) $ do
prog <- getProgramName
- putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
+ warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
if simple_output then show_simple stack else do
if simple_output then show_simple stack else do
@@
-1071,13
+1063,16
@@
checkConsistency verbosity my_flags = do
let pkgs = allPackagesInStack db_stack
checkPackage p = 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
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) ++ ":")
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]
return ()
return [p]
@@
-1163,26
+1158,32
@@
writeNewConfig verbosity filename ipis = do
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.
-- 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
instance Monad Validate where
- return a = V $ return (a, [])
+ return a = V $ return (a, [], [])
m >>= k = V $ do
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 :: 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 :: IO a -> Validate a
-liftIO k = V (k >>= \a -> return (a,[]))
+liftIO k = V (k >>= \a -> return (a,[],[]))
-- returns False if we should die
-- 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
oks <- mapM report es
return (and oks)
where
@@
-1208,8
+1209,8
@@
validatePackageConfig :: InstalledPackageInfo
-> Force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
-> 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
when (not ok) $ exitWith (ExitFailure 1)
checkPackageConfig :: InstalledPackageInfo
@@
-1223,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)
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?
checkModules pkg
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
@@
-1278,15
+1279,22
@@
checkDuplicates db_stack pkg update = do
" overlaps with: " ++ unwords (map display dups)
" 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
| "$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) $
| 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
checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
checkDep db_stack pkgid
@@
-1344,7
+1352,7
@@
checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
| otherwise = do
m <- doesFileExistOnPath ghci_lib_file dirs
when (isNothing m && ghci_lib_file /= "HSrts.o") $
| otherwise = do
m <- doesFileExistOnPath ghci_lib_file dirs
when (isNothing m && ghci_lib_file /= "HSrts.o") $
- hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
+ warn ("warning: can't find GHCi lib " ++ ghci_lib_file)
where
ghci_lib_file = lib <.> "o"
where
ghci_lib_file = lib <.> "o"
@@
-1451,6
+1459,9
@@
dieOrForceAll :: Force -> String -> IO ()
dieOrForceAll ForceAll s = ignoreError s
dieOrForceAll _other s = dieForcible s
dieOrForceAll ForceAll s = ignoreError s
dieOrForceAll _other s = dieForcible s
+warn :: String -> IO ()
+warn = reportError
+
ignoreError :: String -> IO ()
ignoreError s = reportError (s ++ " (ignoring)")
ignoreError :: String -> IO ()
ignoreError s = reportError (s ++ " (ignoring)")
@@
-1517,7
+1528,7
@@
installSignalHandlers = do
_ <- installHandler sigQUIT (Catch interrupt) Nothing
_ <- installHandler sigINT (Catch interrupt) Nothing
return ()
_ <- 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
-- 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
@@
-1529,13
+1540,6
@@
installSignalHandlers = do
_ <- installHandler (Catch sig_handler)
return ()
_ <- 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
#endif
#if mingw32_HOST_OS || mingw32_TARGET_OS
@@
-1578,7
+1582,7
@@
withFileAtomic targetFile write_content = do
`catchIO` \err -> do
exists <- doesFileExist targetFile
if exists
`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
-- Big fat hairy race condition
renameFile newFile targetFile
-- If the removeFile succeeds and the renameFile fails
@@
-1588,7
+1592,7
@@
withFileAtomic targetFile write_content = do
renameFile newFile targetFile
#endif
`Exception.onException` do hClose newHandle
renameFile newFile targetFile
#endif
`Exception.onException` do hClose newHandle
- removeFile newFile
+ removeFileSafe newFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
@@
-1629,9
+1633,7
@@
openNewFile dir template = do
oflags = rw_flags .|. o_EXCL
oflags = rw_flags .|. o_EXCL
-#if __GLASGOW_HASKELL__ < 611
withFilePath = withCString
withFilePath = withCString
-#endif
findTempName x = do
fd <- withFilePath filepath $ \ f ->
findTempName x = do
fd <- withFilePath filepath $ \ f ->
@@
-1647,11
+1649,7
@@
openNewFile dir template = do
-- as any exceptions etc will only be able to report the
-- fd currently
h <-
-- as any exceptions etc will only be able to report the
-- fd currently
h <-
-#if __GLASGOW_HASKELL__ >= 609
fdToHandle fd
fdToHandle fd
-#else
- fdToHandle (fromIntegral fd)
-#endif
`Exception.onException` c_close fd
return (filepath, h)
where
`Exception.onException` c_close fd
return (filepath, h)
where
@@
-1693,3
+1691,9
@@
readUTF8File file = do
hSetEncoding h utf8
#endif
hGetContents h
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