X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=e110cb4b3cf4dd7fc987bca161e9258f3b485773;hb=5d5410209524eb3e3b39619ba398dbb924ae91c0;hp=411dc56afdf60b02d7ceec15caba91772dcdbf3c;hpb=930421d4ed09e5389e0ef4c5eef36075a6809cc0;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 411dc56..e110cb4 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -10,7 +10,7 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) -import Distribution.InstalledPackageInfo.Binary +import Distribution.InstalledPackageInfo.Binary() import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ModuleName hiding (main) import Distribution.InstalledPackageInfo @@ -48,28 +48,39 @@ import System.IO.Error (try) import Data.List import Control.Concurrent +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin + +#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 -#ifdef mingw32_HOST_OS -import GHC.ConsoleHandler -#else -import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError ) +#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 +#else +import System.Posix hiding (fdToHandle) +#endif + +import IO ( isPermissionError ) #if defined(GLOB) import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif -#if __GLASGOW_HASKELL__ >= 611 +#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING) import System.Console.Terminfo as Terminfo #endif @@ -169,14 +180,20 @@ ourCopyright = "GHC package manager version " ++ Version.version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ "Usage:\n" ++ + " $p init {path}\n" ++ + " Create and initialise a package database at the location {path}.\n" ++ + " Packages can be registered in the new database using the register\n" ++ + " command with --package-conf={path}. To use the new database with GHC,\n" ++ + " use GHC's -package-conf flag.\n" ++ + "\n" ++ " $p register {filename | -}\n" ++ " Register the package using the specified installed package\n" ++ " description. The syntax for the latter is given in the $p\n" ++ - " documentation.\n" ++ + " documentation. The input file should be encoded in UTF-8.\n" ++ "\n" ++ " $p update {filename | -}\n" ++ " Register the package, overwriting any other package with the\n" ++ - " same name.\n" ++ + " same name. The input file should be encoded in UTF-8.\n" ++ "\n" ++ " $p unregister {pkg-id}\n" ++ " Unregister the specified package.\n" ++ @@ -223,7 +240,15 @@ usageHeader prog = substProg prog $ " $p dump\n" ++ " Dump the registered description for every package. This is like\n" ++ " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ - " by tools that parse the results, rather than humans.\n" ++ + " by tools that parse the results, rather than humans. The output is\n" ++ + " always encoded in UTF-8, regardless of the current locale.\n" ++ + "\n" ++ + " $p recache\n" ++ + " Regenerate the package database cache. This command should only be\n" ++ + " necessary if you added a package to the database by dropping a file\n" ++ + " into the database directory manually. By default, the global DB\n" ++ + " is recached; to recache a different DB use --user or --package-conf\n" ++ + " as appropriate.\n" ++ "\n" ++ " Substring matching is supported for {module} in find-module and\n" ++ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ @@ -302,6 +327,8 @@ runit verbosity cli nonopts = do print filename glob filename >>= print #endif + ["init", filename] -> + initPackageDB filename verbosity cli ["register", filename] -> registerPackage filename verbosity cli auto_ghci_libs False force ["update", filename] -> @@ -545,19 +572,19 @@ readParseDatabase verbosity mb_user_conf use_cache path 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 when (verbosity > Normal) $ putStrLn ("using cache: " ++ cache) - pkgs <- readBinPackageDB cache + pkgs <- myReadBinPackageDB cache let pkgs' = map convertPackageInfoIn pkgs 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 @@ -566,11 +593,22 @@ readParseDatabase verbosity mb_user_conf use_cache path map (path ) confs return PackageDB { location = path, packages = pkgs } +-- read the package.cache file strictly, to work around a problem with +-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed +-- after it has been completely read, leading to a sharing violation +-- later. +myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString] +myReadBinPackageDB filepath = do + h <- openBinaryFile filepath ReadMode + sz <- hFileSize h + b <- B.hGet h (fromIntegral sz) + hClose h + return $ Bin.runGet Bin.get b parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo] parseMultiPackageConf verbosity file = do when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file) - str <- readFile file + str <- readUTF8File file let pkgs = map convertPackageInfoIn $ read str Exception.evaluate pkgs `catchError` \e-> @@ -579,12 +617,24 @@ parseMultiPackageConf verbosity file = do parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo parseSingletonPackageConf verbosity file = do when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file) - readFile file >>= parsePackageInfo + readUTF8File file >>= parsePackageInfo cachefilename :: FilePath cachefilename = "package.cache" -- ----------------------------------------------------------------------------- +-- Creating a new package DB + +initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB filename verbosity _flags = do + let eexist = die ("cannot create: " ++ filename ++ " already exists") + b1 <- doesFileExist filename + when b1 eexist + b2 <- doesDirectoryExist filename + when b2 eexist + changeDB verbosity [] PackageDB{ location = filename, packages = [] } + +-- ----------------------------------------------------------------------------- -- Registering registerPackage :: FilePath @@ -607,11 +657,15 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do "-" -> do when (verbosity >= Normal) $ putStr "Reading package info from stdin ... " +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdin utf8 +#endif getContents f -> do when (verbosity >= Normal) $ putStr ("Reading package info from " ++ show f ++ " ... ") - readFile f + readUTF8File f expanded <- expandEnvVars s force @@ -679,7 +733,7 @@ changeDBDir verbosity cmds db = do do_cmd (AddPackage p) = do let file = location db display (installedPackageId p) <.> "conf" when (verbosity > Normal) $ putStrLn ("writing " ++ file) - writeFileAtomic file (showInstalledPackageInfo p) + writeFileUtf8Atomic file (showInstalledPackageInfo p) do_cmd (ModifyPackage p) = do_cmd (AddPackage p) @@ -688,7 +742,7 @@ updateDBCache verbosity db = do let filename = location db cachefilename when (verbosity > Normal) $ putStrLn ("writing cache " ++ filename) - writeBinPackageDB filename (map convertPackageInfoOut (packages db)) + writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) `catch` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") @@ -806,11 +860,11 @@ listPackages verbosity my_flags mPackageName mModuleName = do 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 __GLASGOW_HASKELL__ < 611 +#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING) mapM_ show_normal stack #else let @@ -855,7 +909,7 @@ showPackageDot verbosity myflags = do getPkgDatabases verbosity False True{-use cache-} myflags let all_pkgs = allPackagesInStack flag_db_stack - ipix = PackageIndex.listToInstalledPackageIndex all_pkgs + ipix = PackageIndex.fromList all_pkgs putStrLn "digraph {" let quote s = '"':s ++ "\"" @@ -863,7 +917,7 @@ showPackageDot verbosity myflags = do | p <- all_pkgs, let from = display (sourcePackageId p), depid <- depends p, - Just dep <- [PackageIndex.lookupInstalledPackage ipix depid], + Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid], let to = display (sourcePackageId dep) ] putStrLn "}" @@ -899,7 +953,12 @@ dumpPackages verbosity my_flags = do doDump (allPackagesInStack flag_db_stack) doDump :: [InstalledPackageInfo] -> IO () -doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo +doDump pkgs = do +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdout utf8 +#endif + mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] @@ -1016,13 +1075,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] @@ -1096,7 +1158,7 @@ writeNewConfig verbosity filename ipis = do let shown = concat $ intersperse ",\n " $ map (show . convertPackageInfoOut) ipis fileContents = "[" ++ shown ++ "\n]" - writeFileAtomic filename fileContents + writeFileUtf8Atomic filename fileContents `catch` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") @@ -1108,26 +1170,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 @@ -1153,8 +1221,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 @@ -1168,9 +1236,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? @@ -1223,15 +1291,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 @@ -1289,7 +1364,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") $ - 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" @@ -1396,6 +1471,9 @@ dieOrForceAll :: Force -> String -> IO () dieOrForceAll ForceAll s = ignoreError s dieOrForceAll _other s = dieForcible s +warn :: String -> IO () +warn = reportError + ignoreError :: String -> IO () ignoreError s = reportError (s ++ " (ignoring)") @@ -1496,12 +1574,26 @@ catchError io handler = io `Exception.catch` handler' where handler' (Exception.ErrorCall err) = handler err +writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO () +writeBinaryFileAtomic targetFile obj = + withFileAtomic targetFile $ \h -> do + hSetBinaryMode h True + B.hPutStr h (Bin.encode obj) + +writeFileUtf8Atomic :: FilePath -> String -> IO () +writeFileUtf8Atomic targetFile content = + withFileAtomic targetFile $ \h -> do +#if __GLASGOW_HASKELL__ >= 612 + hSetEncoding h utf8 +#endif + hPutStr h content + -- copied from Cabal's Distribution.Simple.Utils, except that we want -- to use text files here, rather than binary files. -writeFileAtomic :: FilePath -> String -> IO () -writeFileAtomic targetFile content = do +withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO () +withFileAtomic targetFile write_content = do (newFile, newHandle) <- openNewFile targetDir template - do hPutStr newHandle content + do write_content newHandle hClose newHandle #if mingw32_HOST_OS || mingw32_TARGET_OS renameFile newFile targetFile @@ -1528,10 +1620,16 @@ writeFileAtomic targetFile content = do -- to always return a valid dir (targetDir_,targetName) = splitFileName targetFile --- Ugh, this is a copy/paste of code from the base library, but --- if uses 666 rather than 600 for the permissions. openNewFile :: FilePath -> String -> IO (FilePath, Handle) openNewFile dir template = do +#if __GLASGOW_HASKELL__ >= 612 + -- this was added to System.IO in 6.12.1 + -- we must use this version because the version below opens the file + -- in binary mode. + openTempFileWithDefaultPermissions dir template +#else + -- Ugh, this is a copy/paste of code from the base library, but + -- if uses 666 rather than 600 for the permissions. pid <- c_getpid findTempName pid where @@ -1588,6 +1686,7 @@ std_flags, output_flags, rw_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT rw_flags = output_flags .|. o_RDWR +#endif /* GLASGOW_HASKELL < 612 */ -- | The function splits the given string to substrings -- using 'isSearchPathSeparator'. @@ -1608,3 +1707,12 @@ parseSearchPath path = split path _ -> chunk' (chunk', rest') = break isSearchPathSeparator s + +readUTF8File :: FilePath -> IO String +readUTF8File file = do + h <- openFile file ReadMode +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8 + hSetEncoding h utf8 +#endif + hGetContents h