X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=e843d88a38846a878feffe78af3e9a40bfc27aab;hp=416ecc17bc504f3eba08ffb1750e0ba7d8a07d99;hb=b00e3a6c0a82a8af3238d677f798d812cd7fd49f;hpb=68f7cd160712d9666a492703f7d4a89ad7e9158c diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 416ecc1..e843d88 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,72 +1,72 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- --- (c) The University of Glasgow 2004. +-- (c) The University of Glasgow 2004-2009. -- -- Package management tool -- ----------------------------------------------------------------------------- --- TODO: --- * validate modules --- * expanding of variables in new-style package conf --- * version manipulation (checking whether old version exists, --- hiding old version?) - module Main (main) where import Version ( version, targetOS, targetARCH ) +import Distribution.InstalledPackageInfo.Binary() +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.ModuleName hiding (main) import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP import Distribution.ParseUtils -import Distribution.Package +import Distribution.Package hiding (depends) +import Distribution.Text import Distribution.Version import System.FilePath - -#ifdef USING_COMPAT -import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) -import Compat.RawSystem ( rawSystem ) -#else -import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) import System.Cmd ( rawSystem ) -#endif +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, + getModificationTime ) +import Text.Printf import Prelude -#include "../../includes/ghcconfig.h" - import System.Console.GetOpt -import Text.PrettyPrint import qualified Control.Exception as Exception import Data.Maybe import Data.Char ( isSpace, toLower ) import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, +import System.Directory ( doesDirectoryExist, getDirectoryContents, doesFileExist, renameFile, removeFile ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO -import System.IO.Error (try) -import Data.List ( isPrefixOf, isSuffixOf, isInfixOf, intersperse, sortBy, nub, - unfoldr, break ) +import System.IO.Error +import Data.List import Control.Concurrent -#ifdef mingw32_HOST_OS +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin + +#if defined(mingw32_HOST_OS) +-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile import Foreign -import Foreign.C.String +import Foreign.C +#endif + +#ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else -import System.Posix +import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError, isDoesNotExistError ) - #if defined(GLOB) import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif +#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) +import System.Console.Terminfo as Terminfo +#endif + -- ----------------------------------------------------------------------------- -- Entry point @@ -81,7 +81,9 @@ main = do (cli,_,[]) | FlagVersion `elem` cli -> bye ourCopyright (cli,nonopts,[]) -> - runit cli nonopts + case getVerbosity Normal cli of + Right v -> runit v cli nonopts + Left err -> die err (_,_,errors) -> do prog <- getProgramName die (concat errors ++ usageInfo (usageHeader prog) flags) @@ -102,6 +104,8 @@ data Flag | FlagSimpleOutput | FlagNamesOnly | FlagIgnoreCase + | FlagNoUserDb + | FlagVerbosity (Maybe String) deriving Eq flags :: [OptDescr Flag] @@ -114,6 +118,8 @@ flags = [ "use the specified package config file", Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") "location of the global package config", + Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) + "never read the user package database", Option [] ["force"] (NoArg FlagForce) "ignore missing dependencies, directories, and libraries", Option [] ["force-files"] (NoArg FlagForceFiles) @@ -129,9 +135,23 @@ flags = [ Option [] ["names-only"] (NoArg FlagNamesOnly) "only print package names, not versions; can only be used with list --simple-output", Option [] ["ignore-case"] (NoArg FlagIgnoreCase) - "ignore case for substring matching" + "ignore case for substring matching", + Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") + "verbosity level (0-2, default 1)" ] +data Verbosity = Silent | Normal | Verbose + deriving (Show, Eq, Ord) + +getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity +getVerbosity v [] = Right v +getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs +getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs +getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v) +getVerbosity v (_ : fs) = getVerbosity v fs + deprecFlags :: [OptDescr Flag] deprecFlags = [ -- put deprecated flags here @@ -143,14 +163,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" ++ @@ -164,12 +190,17 @@ usageHeader prog = substProg prog $ " $p list [pkg]\n" ++ " List registered packages in the global database, and also the\n" ++ " user database if --user is given. If a package name is given\n" ++ - " All the registered versions will be listed in ascending order.\n" ++ + " all the registered versions will be listed in ascending order.\n" ++ " Accepts the --simple-output flag.\n" ++ "\n" ++ + " $p dot\n" ++ + " Generate a graph of the package dependencies in a form suitable\n" ++ + " for input for the graphviz tools. For example, to generate a PDF" ++ + " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++ + "\n" ++ " $p find-module {module}\n" ++ " List registered packages exposing module {module} in the global\n" ++ - " database, and also the user database if --user is given. \n" ++ + " database, and also the user database if --user is given.\n" ++ " All the registered versions will be listed in ascending order.\n" ++ " Accepts the --simple-output flag.\n" ++ "\n" ++ @@ -189,6 +220,19 @@ usageHeader prog = substProg prog $ " Extract the specified field of the package description for the\n" ++ " specified package. Accepts comma-separated multiple fields.\n" ++ "\n" ++ + " $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. 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" ++ " open substring ends (prefix*, *suffix, *infix*).\n" ++ @@ -200,7 +244,7 @@ usageHeader prog = substProg prog $ " entirely. When multiple of these options are given, the rightmost\n"++ " one is used as the database to act upon.\n"++ "\n"++ - " Commands that query the package database (list, latest, describe,\n"++ + " Commands that query the package database (list, tree, latest, describe,\n"++ " field) operate on the list of databases specified by the flags\n"++ " --user, --global, and --package-conf. If none of these flags are\n"++ " given, the default is --global --user.\n"++ @@ -215,12 +259,13 @@ substProg prog (c:xs) = c : substProg prog xs -- ----------------------------------------------------------------------------- -- Do the business -data Force = ForceAll | ForceFiles | NoForce +data Force = NoForce | ForceFiles | ForceAll | CannotForce + deriving (Eq,Ord) data PackageArg = Id PackageIdentifier | Substring String (String->Bool) -runit :: [Flag] -> [String] -> IO () -runit cli nonopts = do +runit :: Verbosity -> [Flag] -> [String] -> IO () +runit verbosity cli nonopts = do installSignalHandlers -- catch ^C and clean up prog <- getProgramName let @@ -265,45 +310,57 @@ runit cli nonopts = do print filename glob filename >>= print #endif + ["init", filename] -> + initPackageDB filename verbosity cli ["register", filename] -> - registerPackage filename cli auto_ghci_libs False force + registerPackage filename verbosity cli auto_ghci_libs False force ["update", filename] -> - registerPackage filename cli auto_ghci_libs True force + registerPackage filename verbosity cli auto_ghci_libs True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid cli + unregisterPackage pkgid verbosity cli force ["expose", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid cli + exposePackage pkgid verbosity cli force ["hide", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid cli + hidePackage pkgid verbosity cli force ["list"] -> do - listPackages cli Nothing Nothing + listPackages verbosity cli Nothing Nothing ["list", pkgid_str] -> case substringCheck pkgid_str of Nothing -> do pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just (Id pkgid)) Nothing - Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing + listPackages verbosity cli (Just (Id pkgid)) Nothing + Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing + ["dot"] -> do + showPackageDot verbosity cli ["find-module", moduleName] -> do let match = maybe (==moduleName) id (substringCheck moduleName) - listPackages cli Nothing (Just match) + listPackages verbosity cli Nothing (Just match) ["latest", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - latestPackage cli pkgid + latestPackage verbosity cli pkgid ["describe", pkgid_str] -> case substringCheck pkgid_str of Nothing -> do pkgid <- readGlobPkgId pkgid_str - describePackage cli (Id pkgid) - Just m -> describePackage cli (Substring pkgid_str m) + describePackage verbosity cli (Id pkgid) + Just m -> describePackage verbosity cli (Substring pkgid_str m) ["field", pkgid_str, fields] -> case substringCheck pkgid_str of Nothing -> do pkgid <- readGlobPkgId pkgid_str - describeField cli (Id pkgid) (splitFields fields) - Just m -> describeField cli (Substring pkgid_str m) + describeField verbosity cli (Id pkgid) + (splitFields fields) + Just m -> describeField verbosity cli (Substring pkgid_str m) (splitFields fields) ["check"] -> do - checkConsistency cli + checkConsistency verbosity cli + + ["dump"] -> do + dumpPackages verbosity cli + + ["recache"] -> do + recache verbosity cli + [] -> do die ("missing command\n" ++ usageInfo (usageHeader prog) flags) @@ -322,9 +379,10 @@ readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" parseGlobPackageId :: ReadP r PackageIdentifier parseGlobPackageId = - parsePackageId + parse +++ - (do n <- parsePackageName; string "-*" + (do n <- parse + _ <- string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) -- globVersion means "all versions" @@ -343,52 +401,74 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } -- Some commands operate on multiple databases, with overlapping semantics: -- list, describe, field -type PackageDBName = FilePath -type PackageDB = [InstalledPackageInfo] +data PackageDB + = PackageDB { location :: FilePath, + packages :: [InstalledPackageInfo] } -type PackageDBStack = [(PackageDBName,PackageDB)] +type PackageDBStack = [PackageDB] -- A stack of package databases. Convention: head is the topmost - -- in the stack. Earlier entries override later one. + -- in the stack. + +allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] +allPackagesInStack = concatMap packages -getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack -getPkgDatabases modify flags = do +getPkgDatabases :: Verbosity + -> Bool -- we are modifying, not reading + -> Bool -- read caches, if available + -> [Flag] + -> IO (PackageDBStack, + -- the real package DB stack: [global,user] ++ + -- DBs specified on the command line with -f. + Maybe FilePath, + -- which one to modify, if any + PackageDBStack) + -- the package DBs specified on the command + -- line, or [global,user] otherwise. This + -- is used as the list of package DBs for + -- commands that just read the DB, such as 'list'. + +getPkgDatabases verbosity modify use_cache my_flags = do -- first we determine the location of the global package config. On Windows, -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the -- location is passed to the binary using the --global-config flag by the -- wrapper script. let err_msg = "missing --global-conf option, location of global package.conf unknown\n" global_conf <- - case [ f | FlagGlobalConfig f <- flags ] of - [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" + case [ f | FlagGlobalConfig f <- my_flags ] of + [] -> do mb_dir <- getLibDir case mb_dir of - Nothing -> die err_msg - Just dir -> return (dir "package.conf") + Nothing -> die err_msg + Just dir -> do + r <- lookForPackageDBIn dir + case r of + Nothing -> die ("Can't find package database in " ++ dir) + Just path -> return path fs -> return (last fs) - let global_conf_dir = global_conf ++ ".d" - global_conf_dir_exists <- doesDirectoryExist global_conf_dir - global_confs <- - if global_conf_dir_exists - then do files <- getDirectoryContents global_conf_dir - return [ global_conf_dir ++ '/' : file - | file <- files - , isSuffixOf ".conf" file] - else return [] + let no_user_db = FlagNoUserDb `elem` my_flags -- get the location of the user package database, and create it if necessary - appdir <- getAppUserDataDirectory "ghc" - - let - subdir = targetARCH ++ '-':targetOS ++ '-':Version.version - archdir = appdir subdir - user_conf = archdir "package.conf" - user_exists <- doesFileExist user_conf + -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set) + e_appdir <- try $ getAppUserDataDirectory "ghc" + + mb_user_conf <- + if no_user_db then return Nothing else + case e_appdir of + Left _ -> return Nothing + Right appdir -> do + let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version + dir = appdir subdir + r <- lookForPackageDBIn dir + case r of + Nothing -> return (Just (dir "package.conf.d", False)) + Just f -> return (Just (f, True)) -- If the user database doesn't exist, and this command isn't a -- "modify" command, then we won't attempt to create or use it. let sys_databases - | modify || user_exists = user_conf : global_confs ++ [global_conf] - | otherwise = global_confs ++ [global_conf] + | Just (user_conf,user_exists) <- mb_user_conf, + modify || user_exists = [user_conf, global_conf] + | otherwise = [global_conf] e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = @@ -397,97 +477,193 @@ getPkgDatabases modify flags = do Right path | last cs == "" -> init cs ++ sys_databases | otherwise -> cs - where cs = splitSearchPath path + where cs = parseSearchPath path -- The "global" database is always the one at the bottom of the stack. -- This is the database we modify by default. virt_global_conf = last env_stack - let db_flags = [ f | Just f <- map is_db_flag flags ] - where is_db_flag FlagUser = Just user_conf + let db_flags = [ f | Just f <- map is_db_flag my_flags ] + where is_db_flag FlagUser + | Just (user_conf, _user_exists) <- mb_user_conf + = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf is_db_flag (FlagConfig f) = Just f is_db_flag _ = Nothing - final_stack <- - if not modify - then -- For a "read" command, we use all the databases - -- specified on the command line. If there are no - -- command-line flags specifying databases, the default - -- is to use all the ones we know about. - if null db_flags then return env_stack - else return (reverse (nub db_flags)) - else let - -- For a "modify" command, treat all the databases as - -- a stack, where we are modifying the top one, but it - -- can refer to packages in databases further down the - -- stack. - - -- -f flags on the command line add to the database - -- stack, unless any of them are present in the stack - -- already. - flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse flags ] - ++ env_stack - - modifying f - | f `elem` flag_stack = return (dropWhile (/= f) flag_stack) - | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.") - in - if null db_flags - then modifying virt_global_conf - else modifying (head db_flags) - - db_stack <- mapM readParseDatabase final_stack - return db_stack - -readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) -readParseDatabase filename = do - str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig - let packages = read str - Exception.evaluate packages - `Exception.catch` \e-> - die ("error while parsing " ++ filename ++ ": " ++ show e) - return (filename,packages) - -emptyPackageConfig :: String -emptyPackageConfig = "[]" + let flag_db_names | null db_flags = env_stack + | otherwise = reverse (nub db_flags) + + -- For a "modify" command, treat all the databases as + -- a stack, where we are modifying the top one, but it + -- can refer to packages in databases further down the + -- stack. + + -- -f flags on the command line add to the database + -- stack, unless any of them are present in the stack + -- already. + let final_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse my_flags ] + ++ env_stack + + -- the database we actually modify is the one mentioned + -- rightmost on the command-line. + let to_modify + | not modify = Nothing + | null db_flags = Just virt_global_conf + | otherwise = Just (last db_flags) + + db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack + + let flag_db_stack = [ db | db_name <- flag_db_names, + db <- db_stack, location db == db_name ] + + return (db_stack, to_modify, flag_db_stack) + + +lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) +lookForPackageDBIn dir = do + let path_dir = dir "package.conf.d" + exists_dir <- doesDirectoryExist path_dir + if exists_dir then return (Just path_dir) else do + let path_file = dir "package.conf" + exists_file <- doesFileExist path_file + if exists_file then return (Just path_file) else return Nothing + +readParseDatabase :: Verbosity + -> Maybe (FilePath,Bool) + -> Bool -- use cache + -> FilePath + -> IO PackageDB + +readParseDatabase verbosity mb_user_conf use_cache path + -- the user database (only) is allowed to be non-existent + | Just (user_conf,False) <- mb_user_conf, path == user_conf + = return PackageDB { location = path, packages = [] } + | otherwise + = do e <- try $ getDirectoryContents path + case e of + Left _ -> do + pkgs <- parseMultiPackageConf verbosity path + return PackageDB{ location = path, packages = pkgs } + Right fs + | not use_cache -> ignore_cache + | otherwise -> do + let cache = path cachefilename + tdir <- getModificationTime path + e_tcache <- try $ getModificationTime cache + case e_tcache of + Left ex -> do + when (verbosity > Normal) $ + warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex) + ignore_cache + Right tcache + | tcache >= tdir -> do + when (verbosity > Normal) $ + putStrLn ("using cache: " ++ cache) + pkgs <- myReadBinPackageDB cache + let pkgs' = map convertPackageInfoIn pkgs + return PackageDB { location = path, packages = pkgs' } + | otherwise -> do + when (verbosity >= Normal) $ do + warn ("WARNING: cache is out of date: " ++ cache) + warn " use 'ghc-pkg recache' to fix." + ignore_cache + where + ignore_cache = do + let confs = filter (".conf" `isSuffixOf`) fs + pkgs <- mapM (parseSingletonPackageConf verbosity) $ + 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 <- readUTF8File file + let pkgs = map convertPackageInfoIn $ read str + Exception.evaluate pkgs + `catchError` \e-> + die ("error while parsing " ++ file ++ ": " ++ show e) + +parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo +parseSingletonPackageConf verbosity file = do + when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file) + 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 + -> Verbosity -> [Flag] -> Bool -- auto_ghci_libs -> Bool -- update -> Force -> IO () -registerPackage input flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True flags +registerPackage input verbosity my_flags auto_ghci_libs update force = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True True my_flags + let - db_to_operate_on = my_head "db" db_stack - db_filename = fst db_to_operate_on + db_to_operate_on = my_head "register" $ + filter ((== to_modify).location) db_stack -- - s <- case input of "-" -> do - putStr "Reading package info from stdin ... " + when (verbosity >= Normal) $ + putStr "Reading package info from stdin ... " + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdin utf8 getContents f -> do - putStr ("Reading package info from " ++ show f ++ " ... ") - readFile f + when (verbosity >= Normal) $ + putStr ("Reading package info from " ++ show f ++ " ... ") + readUTF8File f expanded <- expandEnvVars s force pkg <- parsePackageInfo expanded - putStrLn "done." - - validatePackageConfig pkg db_stack auto_ghci_libs update force - let new_details = filter not_this (snd db_to_operate_on) ++ [pkg] - not_this p = package p /= package pkg - savingOldConfig db_filename $ - writeNewConfig db_filename new_details + when (verbosity >= Normal) $ + putStrLn "done." + + let truncated_stack = dropWhile ((/= to_modify).location) db_stack + -- truncate the stack for validation, because we don't allow + -- packages lower in the stack to refer to those higher up. + validatePackageConfig pkg truncated_stack auto_ghci_libs update force + let + removes = [ RemovePackage p + | p <- packages db_to_operate_on, + sourcePackageId p == sourcePackageId pkg ] + -- + changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on parsePackageInfo :: String @@ -500,126 +676,299 @@ parsePackageInfo str = (Just l, s) -> die (show l ++ ": " ++ s) -- ----------------------------------------------------------------------------- +-- Making changes to a package database + +data DBOp = RemovePackage InstalledPackageInfo + | AddPackage InstalledPackageInfo + | ModifyPackage InstalledPackageInfo + +changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDB verbosity cmds db = do + let db' = updateInternalDB db cmds + isfile <- doesFileExist (location db) + if isfile + then writeNewConfig verbosity (location db') (packages db') + else do + createDirectoryIfMissing True (location db) + changeDBDir verbosity cmds db' + +updateInternalDB :: PackageDB -> [DBOp] -> PackageDB +updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds } + where + do_cmd pkgs (RemovePackage p) = + filter ((/= installedPackageId p) . installedPackageId) pkgs + do_cmd pkgs (AddPackage p) = p : pkgs + do_cmd pkgs (ModifyPackage p) = + do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p) + + +changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDBDir verbosity cmds db = do + mapM_ do_cmd cmds + updateDBCache verbosity db + where + do_cmd (RemovePackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ putStrLn ("removing " ++ file) + removeFileSafe file + do_cmd (AddPackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ putStrLn ("writing " ++ file) + writeFileUtf8Atomic file (showInstalledPackageInfo p) + do_cmd (ModifyPackage p) = + do_cmd (AddPackage p) + +updateDBCache :: Verbosity -> PackageDB -> IO () +updateDBCache verbosity db = do + let filename = location db cachefilename + when (verbosity > Normal) $ + putStrLn ("writing cache " ++ filename) + writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) + `catchIO` \e -> + if isPermissionError e + then die (filename ++ ": you don't have permission to modify this file") + else ioError e + +-- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar -exposePackage :: PackageIdentifier -> [Flag] -> IO () -exposePackage = modifyPackage (\p -> [p{exposed=True}]) +exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) -hidePackage :: PackageIdentifier -> [Flag] -> IO () -hidePackage = modifyPackage (\p -> [p{exposed=False}]) +hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) -unregisterPackage :: PackageIdentifier -> [Flag] -> IO () -unregisterPackage = modifyPackage (\p -> []) +unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +unregisterPackage = modifyPackage RemovePackage modifyPackage - :: (InstalledPackageInfo -> [InstalledPackageInfo]) + :: (InstalledPackageInfo -> DBOp) -> PackageIdentifier + -> Verbosity -> [Flag] + -> Force -> IO () -modifyPackage fn pkgid flags = do - db_stack <- getPkgDatabases True{-modify-} flags - let ((db_name, pkgs) : _) = db_stack - ps <- findPackages [(db_name,pkgs)] (Id pkgid) - let pids = map package ps - let new_config = concat (map modify pkgs) - modify pkg - | package pkg `elem` pids = fn pkg - | otherwise = [pkg] - savingOldConfig db_name $ - writeNewConfig db_name new_config +modifyPackage fn pkgid verbosity my_flags force = do + (db_stack, Just _to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags + + (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) + let + db_name = location db + pkgs = packages db + + pids = map sourcePackageId ps + + cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ] + new_db = updateInternalDB db cmds + + old_broken = brokenPackages (allPackagesInStack db_stack) + rest_of_stack = filter ((/= db_name) . location) db_stack + new_stack = new_db : rest_of_stack + new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack)) + newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken + -- + when (not (null newly_broken)) $ + dieOrForceAll force ("unregistering " ++ display pkgid ++ + " would break the following packages: " + ++ unwords (map display newly_broken)) + + changeDB verbosity cmds db + +recache :: Verbosity -> [Flag] -> IO () +recache verbosity my_flags = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags + let + db_to_operate_on = my_head "recache" $ + filter ((== to_modify).location) db_stack + -- + changeDB verbosity [] db_to_operate_on -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () -listPackages flags mPackageName mModuleName = do - let simple_output = FlagSimpleOutput `elem` flags - db_stack <- getPkgDatabases False flags +listPackages :: Verbosity -> [Flag] -> Maybe PackageArg + -> Maybe (String->Bool) + -> IO () +listPackages verbosity my_flags mPackageName mModuleName = do + let simple_output = FlagSimpleOutput `elem` my_flags + (db_stack, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} my_flags + let db_stack_filtered -- if a package is given, filter out all other packages | Just this <- mPackageName = - map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) - db_stack + [ db{ packages = filter (this `matchesPkg`) (packages db) } + | db <- flag_db_stack ] | Just match <- mModuleName = -- packages which expose mModuleName - map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs)) - db_stack - | otherwise = db_stack + [ db{ packages = filter (match `exposedInPkg`) (packages db) } + | db <- flag_db_stack ] + | otherwise = flag_db_stack db_stack_sorted - = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ] + = [ db{ packages = sort_pkgs (packages db) } + | db <- db_stack_filtered ] where sort_pkgs = sortBy cmpPkgIds cmpPkgIds pkg1 pkg2 = case pkgName p1 `compare` pkgName p2 of LT -> LT GT -> GT EQ -> pkgVersion p1 `compare` pkgVersion p2 - where (p1,p2) = (package pkg1, package pkg2) + where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2) - match `exposedInPkg` pkg = any match (exposedModules pkg) + stack = reverse db_stack_sorted - pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack - show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map) + match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) - show_func (reverse db_stack_sorted) + pkg_map = allPackagesInStack db_stack + broken = map sourcePackageId (brokenPackages pkg_map) - where show_normal pkg_map (db_name,pkg_confs) = - hPutStrLn stdout (render $ - text db_name <> colon $$ nest 4 packages - ) - where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) + show_normal PackageDB{ location = db_name, packages = pkg_confs } = + hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs) + where + pp_pkgs = map pp_pkg pkg_confs pp_pkg p - | isBrokenPackage p pkg_map = braces doc + | sourcePackageId p `elem` broken = printf "{%s}" doc | exposed p = doc - | otherwise = parens doc - where doc = text (showPackageId (package p)) + | otherwise = printf "(%s)" doc + where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid + | otherwise = pkg + where + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) + + show_simple = simplePackageList my_flags . allPackagesInStack - show_simple db_stack = do - let showPkg = if FlagNamesOnly `elem` flags then pkgName - else showPackageId - pkgs = map showPkg $ sortBy compPkgIdVer $ - map package (concatMap snd db_stack) - when (not (null pkgs)) $ - hPutStrLn stdout $ concat $ intersperse " " pkgs + when (not (null broken) && not simple_output && verbosity /= Silent) $ do + prog <- getProgramName + warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") + + if simple_output then show_simple stack else do + +#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) + mapM_ show_normal stack +#else + let + show_colour withF db = + mconcat $ map (<#> termText "\n") $ + (termText (location db) : + map (termText " " <#>) (map pp_pkg (packages db))) + where + pp_pkg p + | sourcePackageId p `elem` broken = withF Red doc + | exposed p = doc + | otherwise = withF Blue doc + where doc | verbosity >= Verbose + = termText (printf "%s (%s)" pkg ipid) + | otherwise + = termText pkg + where + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) + + is_tty <- hIsTerminalDevice stdout + if not is_tty + then mapM_ show_normal stack + else do tty <- Terminfo.setupTermFromEnv + case Terminfo.getCapability tty withForegroundColor of + Nothing -> mapM_ show_normal stack + Just w -> runTermOutput tty $ mconcat $ + map (show_colour w) stack +#endif + +simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () +simplePackageList my_flags pkgs = do + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display + strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs + when (not (null pkgs)) $ + hPutStrLn stdout $ concat $ intersperse " " strs + +showPackageDot :: Verbosity -> [Flag] -> IO () +showPackageDot verbosity myflags = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} myflags + + let all_pkgs = allPackagesInStack flag_db_stack + ipix = PackageIndex.fromList all_pkgs + + putStrLn "digraph {" + let quote s = '"':s ++ "\"" + mapM_ putStrLn [ quote from ++ " -> " ++ quote to + | p <- all_pkgs, + let from = display (sourcePackageId p), + depid <- depends p, + Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid], + let to = display (sourcePackageId dep) + ] + putStrLn "}" -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package -latestPackage :: [Flag] -> PackageIdentifier -> IO () -latestPackage flags pkgid = do - db_stack <- getPkgDatabases False flags - ps <- findPackages db_stack (Id pkgid) - show_pkg (sortBy compPkgIdVer (map package ps)) +latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () +latestPackage verbosity my_flags pkgid = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} my_flags + + ps <- findPackages flag_db_stack (Id pkgid) + show_pkg (sortBy compPkgIdVer (map sourcePackageId ps)) where show_pkg [] = die "no matches" - show_pkg pids = hPutStrLn stdout (showPackageId (last pids)) + show_pkg pids = hPutStrLn stdout (display (last pids)) -- ----------------------------------------------------------------------------- -- Describe -describePackage :: [Flag] -> PackageArg -> IO () -describePackage flags pkgarg = do - db_stack <- getPkgDatabases False flags - ps <- findPackages db_stack pkgarg - mapM_ (putStrLn . showInstalledPackageInfo) ps +describePackage :: Verbosity -> [Flag] -> PackageArg -> IO () +describePackage verbosity my_flags pkgarg = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} my_flags + ps <- findPackages flag_db_stack pkgarg + doDump ps + +dumpPackages :: Verbosity -> [Flag] -> IO () +dumpPackages verbosity my_flags = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} my_flags + doDump (allPackagesInStack flag_db_stack) + +doDump :: [InstalledPackageInfo] -> IO () +doDump pkgs = do + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdout utf8 + mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] findPackages db_stack pkgarg - = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of - [] -> die ("cannot find package " ++ pkg_msg pkgarg) + = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg + +findPackagesByDB :: PackageDBStack -> PackageArg + -> IO [(PackageDB, [InstalledPackageInfo])] +findPackagesByDB db_stack pkgarg + = case [ (db, matched) + | db <- db_stack, + let matched = filter (pkgarg `matchesPkg`) (packages db), + not (null matched) ] of + [] -> die ("cannot find package " ++ pkg_msg pkgarg) ps -> return ps where - all_pkgs = concat (map snd db_stack) - pkg_msg (Id pkgid) = showPackageId pkgid - pkg_msg (Substring pkgpat _) = "matching "++pkgpat + pkg_msg (Id pkgid) = display pkgid + pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat matches :: PackageIdentifier -> PackageIdentifier -> Bool pid `matches` pid' = (pkgName pid == pkgName pid') && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) +realVersion :: PackageIdentifier -> Bool +realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] + -- when versionBranch == [], this is a glob + matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool -(Id pid) `matchesPkg` pkg = pid `matches` package pkg -(Substring _ m) `matchesPkg` pkg = m (pkgName (package pkg)) +(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg +(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg)) compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 @@ -627,12 +976,13 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 -- ----------------------------------------------------------------------------- -- Field -describeField :: [Flag] -> PackageArg -> [String] -> IO () -describeField flags pkgarg fields = do - db_stack <- getPkgDatabases False flags +describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO () +describeField verbosity my_flags pkgarg fields = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} my_flags fns <- toFields fields - ps <- findPackages db_stack pkgarg - let top_dir = takeDirectory (fst (last db_stack)) + ps <- findPackages flag_db_stack pkgarg + let top_dir = takeDirectory (location (last flag_db_stack)) mapM_ (selectFields fns) (mungePackagePaths top_dir ps) where toFields [] = return [] toFields (f:fs) = case toField f of @@ -679,7 +1029,7 @@ toField "hs_libraries" = Just $ strList . hsLibraries toField "extra_libraries" = Just $ strList . extraLibraries toField "include_dirs" = Just $ strList . includeDirs toField "c_includes" = Just $ strList . includes -toField "package_deps" = Just $ strList . map showPackageId. depends +toField "package_deps" = Just $ strList . map display. depends toField "extra_cc_opts" = Just $ strList . ccOptions toField "extra_ld_opts" = Just $ strList . ldOptions toField "framework_dirs" = Just $ strList . frameworkDirs @@ -693,195 +1043,306 @@ strList = show -- ----------------------------------------------------------------------------- -- Check: Check consistency of installed packages -checkConsistency :: [Flag] -> IO () -checkConsistency flags = do - db_stack <- getPkgDatabases True flags +checkConsistency :: Verbosity -> [Flag] -> IO () +checkConsistency verbosity my_flags = do + (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags -- check behaves like modify for the purposes of deciding which -- databases to use, because ordering is important. - let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack - broken_pkgs = do - (pid, p) <- pkgs - let broken_deps = missingPackageDeps p pkgs - guard (not . null $ broken_deps) - return (pid, broken_deps) - mapM_ (putStrLn . render . show_func) broken_pkgs - where - show_func | FlagSimpleOutput `elem` flags = show_simple - | otherwise = show_normal - show_simple (pid,deps) = - text (showPackageId pid) <> colon - <+> fsep (punctuate comma (map (text . showPackageId) deps)) - show_normal (pid,deps) = - text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:" - $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps))) - -missingPackageDeps :: InstalledPackageInfo - -> [(PackageIdentifier, InstalledPackageInfo)] - -> [PackageIdentifier] -missingPackageDeps pkg pkg_map = - [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++ - [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map] - -isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool -isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map + + let simple_output = FlagSimpleOutput `elem` my_flags + + let pkgs = allPackagesInStack db_stack + + checkPackage p = do + (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True + if null es + 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 ws " " Nothing + return () + return [p] + + broken_pkgs <- concat `fmap` mapM checkPackage pkgs + + let filterOut pkgs1 pkgs2 = filter not_in pkgs2 + where not_in p = sourcePackageId p `notElem` all_ps + all_ps = map sourcePackageId pkgs1 + + let not_broken_pkgs = filterOut broken_pkgs pkgs + (_, trans_broken_pkgs) = closure [] not_broken_pkgs + all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs + + when (not (null all_broken_pkgs)) $ do + if simple_output + then simplePackageList my_flags all_broken_pkgs + else do + reportError ("\nThe following packages are broken, either because they have a problem\n"++ + "listed above, or because they depend on a broken package.") + mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs + + when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) +closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> ([InstalledPackageInfo], [InstalledPackageInfo]) +closure pkgs db_stack = go pkgs db_stack + where + go avail not_avail = + case partition (depsAvailable avail) not_avail of + ([], not_avail') -> (avail, not_avail') + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' + + depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo + -> Bool + depsAvailable pkgs_ok pkg = null dangling + where dangling = filter (`notElem` pids) (depends pkg) + pids = map installedPackageId pkgs_ok + + -- we want mutually recursive groups of package to show up + -- as broken. (#1750) + +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages pkgs = snd (closure [] pkgs) + -- ----------------------------------------------------------------------------- -- Manipulating package.conf files -writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () -writeNewConfig filename packages = do - hPutStr stdout "Writing new package config file... " +type InstalledPackageInfoString = InstalledPackageInfo_ String + +convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString +convertPackageInfoOut + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map display e, + hiddenModules = map display h } + +convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo +convertPackageInfoIn + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map convert e, + hiddenModules = map convert h } + where convert = fromJust . simpleParse + +writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO () +writeNewConfig verbosity filename ipis = do + when (verbosity >= Normal) $ + hPutStr stdout "Writing new package config file... " createDirectoryIfMissing True $ takeDirectory filename - h <- openFile filename WriteMode `catch` \e -> + let shown = concat $ intersperse ",\n " + $ map (show . convertPackageInfoOut) ipis + fileContents = "[" ++ shown ++ "\n]" + writeFileUtf8Atomic filename fileContents + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e - let shown = concat $ intersperse ",\n " $ map show packages - fileContents = "[" ++ shown ++ "\n]" - hPutStrLn h fileContents - hClose h - hPutStrLn stdout "done." - -savingOldConfig :: FilePath -> IO () -> IO () -savingOldConfig filename io = Exception.block $ do - hPutStr stdout "Saving old package config file... " - -- mv rather than cp because we've already done an hGetContents - -- on this file so we won't be able to open it for writing - -- unless we move the old one out of the way... - let oldFile = filename ++ ".old" - restore_on_error <- catch (renameFile filename oldFile >> return True) $ - \err -> do - unless (isDoesNotExistError err) $ do - hPutStrLn stderr (unwords ["Unable to rename", show filename, - "to", show oldFile]) - ioError err - return False - (do hPutStrLn stdout "done."; io) - `Exception.catch` \e -> do - hPutStr stdout ("WARNING: an error was encountered while writing " - ++ "the new configuration.\n") - -- remove any partially complete new version: - try (removeFile filename) - -- and attempt to restore the old one, if we had one: - when restore_on_error $ do - hPutStr stdout "Attempting to restore the old configuration... " - do renameFile oldFile filename - hPutStrLn stdout "done." - `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err) - -- Note the above renameFile sometimes fails on Windows with - -- "permission denied", I have no idea why --SDM. - Exception.throwIO e + when (verbosity >= Normal) $ + hPutStrLn stdout "done." ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. +type ValidateError = (Force,String) +type ValidateWarning = String + +newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } + +instance Monad Validate where + return a = V $ return (a, [], []) + m >>= k = V $ do + (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)],[])) + +vwarn :: String -> Validate () +vwarn s = V (return ((),[],["Warning: " ++ s])) + +liftIO :: IO a -> Validate a +liftIO k = V (k >>= \a -> return (a,[],[])) + +-- returns False if we should die +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 + report (f,s) + | Just force <- mb_force + = if (force >= f) + then do reportError (prefix ++ s ++ " (ignoring)") + return True + else if f < CannotForce + then do reportError (prefix ++ s ++ " (use --force to override)") + return False + else do reportError err + return False + | otherwise = do reportError err + return False + where + err = prefix ++ s + validatePackageConfig :: InstalledPackageInfo -> PackageDBStack -> Bool -- auto-ghc-libs - -> Bool -- update + -> Bool -- update, or check -> Force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do + (_,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 + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update, or check + -> Validate () +checkPackageConfig pkg db_stack auto_ghci_libs update = do + checkInstalledPackageId pkg db_stack update checkPackageId pkg - checkDuplicates db_stack pkg update force - mapM_ (checkDep db_stack force) (depends pkg) - mapM_ (checkDir force) (importDirs pkg) - mapM_ (checkDir force) (libraryDirs pkg) - mapM_ (checkDir force) (includeDirs pkg) - mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg) + checkDuplicates db_stack pkg update + mapM_ (checkDep db_stack) (depends pkg) + checkDuplicateDepends (depends 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? -- extra_libraries :: [String], -- c_includes :: [String], +checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool + -> Validate () +checkInstalledPackageId ipi db_stack update = do + let ipid@(InstalledPackageId str) = installedPackageId ipi + when (null str) $ verror CannotForce "missing id field" + let dups = [ p | p <- allPackagesInStack db_stack, + installedPackageId p == ipid ] + when (not update && not (null dups)) $ + verror CannotForce $ + "package(s) with this id already exist: " ++ + unwords (map (display.packageId) dups) + -- When the package name and version are put together, sometimes we can -- end up with a package id that cannot be parsed. This will lead to -- difficulties when the user wants to refer to the package later, so -- we check that the package id can be parsed properly here. -checkPackageId :: InstalledPackageInfo -> IO () +checkPackageId :: InstalledPackageInfo -> Validate () checkPackageId ipi = - let str = showPackageId (package ipi) in - case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of + let str = display (sourcePackageId ipi) in + case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of [_] -> return () - [] -> die ("invalid package identifier: " ++ str) - _ -> die ("ambiguous package identifier: " ++ str) + [] -> verror CannotForce ("invalid package identifier: " ++ str) + _ -> verror CannotForce ("ambiguous package identifier: " ++ str) -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO () -checkDuplicates db_stack pkg update force = do +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () +checkDuplicates db_stack pkg update = do let - pkgid = package pkg - (_top_db_name, pkgs) : _ = db_stack + pkgid = sourcePackageId pkg + pkgs = packages (head db_stack) -- -- Check whether this package id already exists in this DB -- - when (not update && (pkgid `elem` map package pkgs)) $ - die ("package " ++ showPackageId pkgid ++ " is already installed") + when (not update && (pkgid `elem` map sourcePackageId pkgs)) $ + verror CannotForce $ + "package " ++ display pkgid ++ " is already installed" let - uncasep = map toLower . showPackageId - dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) + uncasep = map toLower . display + dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs) - when (not update && not (null dups)) $ dieOrForceAll force $ + when (not update && not (null dups)) $ verror ForceAll $ "Package names may be treated case-insensitively in the future.\n"++ - "Package " ++ showPackageId pkgid ++ - " overlaps with: " ++ unwords (map showPackageId dups) + "Package " ++ display pkgid ++ + " overlaps with: " ++ unwords (map display dups) -checkDir :: Force -> String -> IO () -checkDir force 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 <- doesDirectoryExist d - when (not there) - (dieOrForceFile force (d ++ " doesn't exist or isn't a directory")) - -checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () -checkDep db_stack force pkgid - | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid - ++ " doesn't exist") + there <- liftIO $ doesDirectoryExist d + when (not there) $ + 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 + | pkgid `elem` pkgids = return () + | otherwise = verror ForceAll ("dependency \"" ++ display pkgid + ++ "\" doesn't exist") where - -- for backwards compat, we treat 0.0 as a special version, - -- and don't check that it actually exists. - real_version = realVersion pkgid - - name_exists = any (\p -> pkgName (package p) == name) all_pkgs - name = pkgName pkgid - - all_pkgs = concat (map snd db_stack) - pkgids = map package all_pkgs - -realVersion :: PackageIdentifier -> Bool -realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] + all_pkgs = allPackagesInStack db_stack + pkgids = map installedPackageId all_pkgs + +checkDuplicateDepends :: [InstalledPackageId] -> Validate () +checkDuplicateDepends deps + | null dups = return () + | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ + unwords (map display dups)) + where + dups = [ p | (p:_:_) <- group (sort deps) ] -checkHSLib :: [String] -> Bool -> Force -> String -> IO () -checkHSLib dirs auto_ghci_libs force lib = do +checkHSLib :: [String] -> Bool -> String -> Validate () +checkHSLib dirs auto_ghci_libs lib = do let batch_lib_file = "lib" ++ lib ++ ".a" - bs <- mapM (doesLibExistIn batch_lib_file) dirs - case [ dir | (exists,dir) <- zip bs dirs, exists ] of - [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++ - " on library path") - (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs - -doesLibExistIn :: String -> String -> IO Bool -doesLibExistIn lib d + m <- liftIO $ doesFileExistOnPath batch_lib_file dirs + case m of + Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ + " on library path") + Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs + +doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) +doesFileExistOnPath file path = go path + where go [] = return Nothing + go (p:ps) = do b <- doesFileExistIn file p + if b then return (Just p) else go ps + +doesFileExistIn :: String -> String -> IO Bool +doesFileExistIn lib d | "$topdir" `isPrefixOf` d = return True | "$httptopdir" `isPrefixOf` d = return True - | otherwise = doesFileExist (d ++ '/':lib) + | otherwise = doesFileExist (d lib) -checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () -checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build - | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file - | otherwise = do - bs <- mapM (doesLibExistIn ghci_lib_file) dirs - case [dir | (exists,dir) <- zip bs dirs, exists] of - [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) - (_:_) -> return () +checkModules :: InstalledPackageInfo -> Validate () +checkModules pkg = do + mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) where - ghci_lib_file = lib ++ ".o" + findModule modl = do + -- there's no .hi file for GHC.Prim + if modl == fromString "GHC.Prim" then return () else do + let file = toFilePath modl <.> "hi" + m <- liftIO $ doesFileExistOnPath file (importDirs pkg) + when (isNothing m) $ + verror ForceFiles ("file " ++ file ++ " is missing") + +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 = return () + where + ghci_lib_file = lib <.> "o" -- automatically build the GHCi version of a batch lib, -- using ld --whole-archive. @@ -894,7 +1355,7 @@ autoBuildGHCiLib dir batch_file ghci_file = do #if defined(darwin_HOST_OS) r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] #elif defined(mingw32_HOST_OS) - execDir <- getExecDir "/bin/ghc-pkg.exe" + execDir <- getLibDir r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #else r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] @@ -913,7 +1374,7 @@ findModules paths = return (concat mms) searchDir path prefix = do - fs <- getDirectoryEntries path `catch` \_ -> return [] + fs <- getDirectoryEntries path `catchIO` \_ -> return [] searchEntries path prefix fs searchEntries path prefix [] = return [] @@ -944,7 +1405,7 @@ okInModuleName c -- expanding environment variables in the package configuration expandEnvVars :: String -> Force -> IO String -expandEnvVars str force = go str "" +expandEnvVars str0 force = go str0 "" where go "" acc = return $! reverse acc go ('$':'{':str) acc | (var, '}':rest) <- break close str @@ -956,7 +1417,7 @@ expandEnvVars str force = go str "" lookupEnvVar :: String -> IO String lookupEnvVar nm = - catch (System.Environment.getEnv nm) + catchIO (System.Environment.getEnv nm) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -973,30 +1434,34 @@ bye :: String -> IO a bye s = putStr s >> exitWith ExitSuccess die :: String -> IO a -die s = do +die = dieWith 1 + +dieWith :: Int -> String -> IO a +dieWith ec s = do hFlush stdout prog <- getProgramName hPutStrLn stderr (prog ++ ": " ++ s) - exitWith (ExitFailure 1) + exitWith (ExitFailure ec) dieOrForceAll :: Force -> String -> IO () dieOrForceAll ForceAll s = ignoreError s dieOrForceAll _other s = dieForcible s -dieOrForceFile :: Force -> String -> IO () -dieOrForceFile ForceAll s = ignoreError s -dieOrForceFile ForceFiles s = ignoreError s -dieOrForceFile _other s = dieForcible s +warn :: String -> IO () +warn = reportError ignoreError :: String -> IO () -ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") +ignoreError s = reportError (s ++ " (ignoring)") + +reportError :: String -> IO () +reportError s = do hFlush stdout; hPutStrLn stderr s dieForcible :: String -> IO () dieForcible s = die (s ++ " (use --force to override)") my_head :: String -> [a] -> a -my_head s [] = error s -my_head s (x:xs) = x +my_head s [] = error s +my_head _ (x : _) = x ----------------------------------------- -- Cut and pasted from ghc/compiler/main/SysTools @@ -1008,26 +1473,33 @@ subst a b ls = map (\ x -> if x == a then b else x) ls unDosifyPath :: FilePath -> FilePath unDosifyPath xs = subst '\\' '/' xs -getExecDir :: String -> IO (Maybe String) +getLibDir :: IO (Maybe String) +getLibDir = fmap (fmap ( "lib")) $ getExecDir "/bin/ghc-pkg.exe" + -- (getExecDir cmd) returns the directory in which the current -- executable, which should be called 'cmd', is running -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, -- you'll get "/a/b/c" back as the result -getExecDir cmd - = allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else do s <- peekCString buf - return (Just (reverse (drop (length cmd) - (reverse (unDosifyPath s))))) - where - len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. +getExecDir :: String -> IO (Maybe String) +getExecDir cmd = + getExecPath >>= maybe (return Nothing) removeCmdSuffix + where initN n = reverse . drop n . reverse + removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath + +getExecPath :: IO (Maybe String) +getExecPath = + allocaArray len $ \buf -> do + ret <- getModuleFileName nullPtr buf len + if ret == 0 then return Nothing + else liftM Just $ peekCString buf + where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. + +foreign import stdcall unsafe "GetModuleFileNameA" + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else -getExecDir :: String -> IO (Maybe String) -getExecDir _ = return Nothing +getLibDir :: IO (Maybe String) +getLibDir = return Nothing #endif ----------------------------------------- @@ -1037,13 +1509,14 @@ installSignalHandlers :: IO () installSignalHandlers = do threadid <- myThreadId let - interrupt = throwTo threadid (Exception.ErrorCall "interrupted") + interrupt = Exception.throwTo threadid + (Exception.ErrorCall "interrupted") -- #if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing - installHandler sigINT (Catch interrupt) Nothing + _ <- 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 @@ -1053,8 +1526,103 @@ installSignalHandlers = do sig_handler Break = interrupt sig_handler _ = return () - installHandler (Catch sig_handler) + _ <- installHandler (Catch sig_handler) return () +#endif + +#if mingw32_HOST_OS || mingw32_TARGET_OS +throwIOIO :: Exception.IOException -> IO a +throwIOIO = Exception.throwIO +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch + +catchError :: IO a -> (String -> IO a) -> IO a +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 + hSetEncoding h utf8 + hPutStr h content + +-- copied from Cabal's Distribution.Simple.Utils, except that we want +-- to use text files here, rather than binary files. +withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO () +withFileAtomic targetFile write_content = do + (newFile, newHandle) <- openNewFile targetDir template + do write_content newHandle + hClose newHandle +#if mingw32_HOST_OS || mingw32_TARGET_OS + renameFile newFile targetFile + -- If the targetFile exists then renameFile will fail + `catchIO` \err -> do + exists <- doesFileExist targetFile + if exists + then do removeFileSafe targetFile + -- Big fat hairy race condition + renameFile newFile targetFile + -- If the removeFile succeeds and the renameFile fails + -- then we've lost the atomic property. + else throwIOIO err #else - return () -- nothing + renameFile newFile targetFile +#endif + `Exception.onException` do hClose newHandle + removeFileSafe newFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = "." + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- to always return a valid dir + (targetDir_,targetName) = splitFileName targetFile + +openNewFile :: FilePath -> String -> IO (FilePath, Handle) +openNewFile dir template = do + -- 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 + +-- | The function splits the given string to substrings +-- using 'isSearchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs #endif + _ -> chunk' + + (chunk', rest') = break isSearchPathSeparator s + +readUTF8File :: FilePath -> IO String +readUTF8File file = do + h <- openFile file ReadMode + -- fix the encoding to UTF-8 + hSetEncoding h utf8 + hGetContents h + +-- removeFileSave doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: FilePath -> IO () +removeFileSafe fn = + removeFile fn `catchIO` \ e -> + when (not $ isDoesNotExistError e) $ ioError e