From 72547264724117d689a7fa400104185557fb2a0c Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 20 Aug 2009 11:09:20 +0000 Subject: [PATCH] Add unique package identifiers (InstalledPackageId) in the package DB See commentary at http://hackage.haskell.org/trac/ghc/wiki/Commentary/Packages --- compiler/ghc.mk | 1 + compiler/ghci/Linker.lhs | 21 +++--- compiler/main/DynFlags.hs | 8 +- compiler/main/PackageConfig.hs | 12 +-- compiler/main/Packages.lhs | 160 ++++++++++++++++++++-------------------- compiler/main/ParsePkgConf.y | 27 +++++-- libffi/package.conf.in | 1 + rts/package.conf.in | 3 +- utils/ghc-cabal/ghc-cabal.hs | 16 ++-- utils/ghc-pkg/Main.hs | 125 ++++++++++++++++++++----------- 10 files changed, 210 insertions(+), 164 deletions(-) diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 64b1213..e8c487f 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -464,6 +464,7 @@ $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS))) ifneq "$(ProjectPatchLevel)" "0" compiler/stage1/inplace-pkg-config-munged: compiler/stage1/inplace-pkg-config sed -e 's/^\(version: .*\)\.$(ProjectPatchLevel)$$/\1/' \ + -e 's/^\(id: .*\)\.$(ProjectPatchLevel)$$/\1/' \ -e 's/^\(hs-libraries: HSghc-.*\)\.$(ProjectPatchLevel)$$/\1/' \ < $< > $@ "$(compiler_stage1_GHC_PKG)" update --force $(compiler_stage1_GHC_PKG_OPTS) $@ diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 419cb4f..4c85ac6 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -51,6 +51,7 @@ import ErrUtils import SrcLoc import qualified Maybes import UniqSet +import FiniteMap import Constants import FastString import Config ( cProjectVersion ) @@ -973,23 +974,25 @@ linkPackages dflags new_pkgs = do linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState -> IO PersistentLinkerState linkPackages' dflags new_pks pls = do - let pkg_map = pkgIdMap (pkgState dflags) - - pkgs' <- link pkg_map (pkgs_loaded pls) new_pks - + pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId] - link pkg_map pkgs new_pkgs = - foldM (link_one pkg_map) pkgs new_pkgs + pkg_map = pkgIdMap (pkgState dflags) + ipid_map = installedPackageIdMap (pkgState dflags) + + link :: [PackageId] -> [PackageId] -> IO [PackageId] + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs - link_one pkg_map pkgs new_pkg + link_one pkgs new_pkg | new_pkg `elem` pkgs -- Already linked = return pkgs | Just pkg_cfg <- lookupPackage pkg_map new_pkg = do { -- Link dependents first - pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg)) + pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ + lookupFM ipid_map ipid + | ipid <- depends pkg_cfg ] -- Now link the package itself ; linkPackage dflags pkg_cfg ; return (new_pkg : pkgs') } diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 55dc8c7..f4975f0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -2058,13 +2058,7 @@ ignorePackage p = upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) setPackageName :: String -> DynFlags -> DynFlags -setPackageName p - | Nothing <- unpackPackageId pid - = ghcError (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier")) - | otherwise - = \s -> s{ thisPackage = pid } - where - pid = stringToPackageId p +setPackageName p s = s{ thisPackage = stringToPackageId p } -- If we're linking a binary, then only targets that produce object -- code are allowed (requests for other target types are ignored). diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index f3cede6..79521c7 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -7,7 +7,7 @@ module PackageConfig ( -- $package_naming -- * PackageId - mkPackageId, packageConfigId, unpackPackageId, + mkPackageId, packageConfigId, -- * The PackageConfig type: information about a package PackageConfig, @@ -28,7 +28,6 @@ import Distribution.ModuleName import Distribution.Package hiding (PackageId) import Distribution.Text import Distribution.Version -import Distribution.Compat.ReadP -- ----------------------------------------------------------------------------- -- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we @@ -62,15 +61,6 @@ mkPackageId = stringToPackageId . display packageConfigId :: PackageConfig -> PackageId packageConfigId = mkPackageId . package --- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if --- we could not parse it as such an object. -unpackPackageId :: PackageId -> Maybe PackageIdentifier -unpackPackageId p - = case [ pid | (pid,"") <- readP_to_S parse str ] of - [] -> Nothing - (pid:_) -> Just pid - where str = packageIdString p - -- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific -- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 7cb3337..38a1f9d 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -42,15 +42,16 @@ import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM +import FiniteMap import Module import Util -import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable +import Maybes import System.Environment ( getEnv ) -import Distribution.InstalledPackageInfo hiding (depends) -import Distribution.Package hiding (depends, PackageId) +import Distribution.InstalledPackageInfo +import Distribution.Package hiding (PackageId,depends) import FastString import ErrUtils ( debugTraceMsg, putMsg, Message ) import Exception @@ -59,7 +60,7 @@ import System.Directory import System.FilePath import Data.Maybe import Control.Monad -import Data.List +import Data.List as List -- --------------------------------------------------------------------------- -- The Package state @@ -113,11 +114,13 @@ data PackageState = PackageState { -- should be in reverse dependency order; that is, a package -- is always mentioned before the packages it depends on. - moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)] -- ModuleEnv mapping + moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping -- Derived from pkgIdMap. -- Maps Module to (pkgconf,exposed), where pkgconf is the -- PackageConfig for the package containing the module, and -- exposed is True if the package exposes that module. + + installedPackageIdMap :: FiniteMap InstalledPackageId PackageId } -- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig' @@ -370,32 +373,27 @@ hideOldPackages dflags pkgs = mapM maybe_hide pkgs findWiredInPackages :: DynFlags -> [PackageConfig] -- database - -> [PackageIdentifier] -- preload packages - -> PackageId -- this package - -> IO ([PackageConfig], - [PackageIdentifier], - PackageId) + -> IO [PackageConfig] -findWiredInPackages dflags pkgs preload this_package = do +findWiredInPackages dflags pkgs = do -- -- Now we must find our wired-in packages, and rename them to -- their canonical names (eg. base-1.0 ==> base). -- let - wired_in_pkgids :: [(PackageId, [String])] - wired_in_pkgids = [ (primPackageId, [""]), - (integerPackageId, [""]), - (basePackageId, [""]), - (rtsPackageId, [""]), - (haskell98PackageId, [""]), - (thPackageId, [""]), - (dphSeqPackageId, [""]), - (dphParPackageId, [""])] - - matches :: PackageConfig -> (PackageId, [String]) -> Bool - pc `matches` (pid, suffixes) - = display (pkgName (package pc)) `elem` - (map (packageIdString pid ++) suffixes) + wired_in_pkgids :: [String] + wired_in_pkgids = map packageIdString + [ primPackageId, + integerPackageId, + basePackageId, + rtsPackageId, + haskell98PackageId, + thPackageId, + dphSeqPackageId, + dphParPackageId ] + + matches :: PackageConfig -> String -> Bool + pc `matches` pid = display (pkgName (package pc)) == pid -- find which package corresponds to each wired-in package -- delete any other packages with the same name @@ -407,33 +405,29 @@ findWiredInPackages dflags pkgs preload this_package = do -- version. To override the default choice, -hide-package -- could be used to hide newer versions. -- - findWiredInPackage :: [PackageConfig] -> (PackageId, [String]) - -> IO (Maybe (PackageIdentifier, PackageId)) + findWiredInPackage :: [PackageConfig] -> String + -> IO (Maybe InstalledPackageId) findWiredInPackage pkgs wired_pkg = let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in case all_ps of [] -> notfound many -> pick (head (sortByVersion many)) where - suffixes = snd wired_pkg notfound = do debugTraceMsg dflags 2 $ ptext (sLit "wired-in package ") - <> ppr (fst wired_pkg) - <> (if null suffixes - then empty - else text (show suffixes)) + <> text wired_pkg <> ptext (sLit " not found.") return Nothing pick :: InstalledPackageInfo_ ModuleName - -> IO (Maybe (PackageIdentifier, PackageId)) + -> IO (Maybe InstalledPackageId) pick pkg = do debugTraceMsg dflags 2 $ ptext (sLit "wired-in package ") - <> ppr (fst wired_pkg) + <> text wired_pkg <> ptext (sLit " mapped to ") <> text (display (package pkg)) - return (Just (package pkg, fst wired_pkg)) + return (Just (installedPackageId pkg)) mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids @@ -454,26 +448,13 @@ findWiredInPackages dflags pkgs preload this_package = do -} updateWiredInDependencies pkgs = map upd_pkg pkgs - where upd_pkg p = p{ package = upd_pid (package p), - depends = map upd_pid (depends p) } - - upd_pid pid = case filter ((== pid) . fst) wired_in_ids of - [] -> pid - ((x, y):_) -> x{ pkgName = PackageName (packageIdString y), - pkgVersion = Version [] [] } - - -- pkgs1 = deleteOtherWiredInPackages pkgs - - pkgs2 = updateWiredInDependencies pkgs - - preload1 = map upd_pid preload + where upd_pkg p + | installedPackageId p `elem` wired_in_ids + = p { package = (package p){ pkgVersion = Version [] [] } } + | otherwise + = p - -- we must return an updated thisPackage, just in case we - -- are actually compiling one of the wired-in packages - Just old_this_pkg = unpackPackageId this_package - new_this_pkg = mkPackageId (upd_pid old_this_pkg) - - return (pkgs2, preload1, new_this_pkg) + return $ updateWiredInDependencies pkgs -- ---------------------------------------------------------------------------- -- @@ -499,12 +480,12 @@ elimDanglingDeps dflags pkgs ignored = go [] pkgs' (new_avail, not_avail) -> go (new_avail ++ avail) (map fst not_avail) depsAvailable :: [PackageConfig] -> PackageConfig - -> Either PackageConfig (PackageConfig, [PackageIdentifier]) + -> Either PackageConfig (PackageConfig, [InstalledPackageId]) depsAvailable pkgs_ok pkg | null dangling = Left pkg | otherwise = Right (pkg, dangling) where dangling = filter (`notElem` pids) (depends pkg) - pids = map package pkgs_ok + pids = map installedPackageId pkgs_ok reportElim (p, deps) = debugTraceMsg dflags 2 $ @@ -542,15 +523,14 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do -- should contain at least rts & base, which is why we pretend that -- the command line contains -package rts & -package base. -- - let new_preload_packages = - map package (pickPackages pkgs0 [ p | ExposePackage p <- flags ]) + let preload1 = map installedPackageId $ + pickPackages pkgs0 [ p | ExposePackage p <- flags ] -- hide packages that are subsumed by later versions pkgs2 <- hideOldPackages dflags pkgs1 -- sort out which packages are wired in - (pkgs3, preload1, new_this_pkg) - <- findWiredInPackages dflags pkgs2 new_preload_packages this_package + pkgs3 <- findWiredInPackages dflags pkgs2 let ignored = map packageConfigId $ pickPackages pkgs0 [ p | IgnorePackage p <- flags ] @@ -558,6 +538,16 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs + ipid_map = listToFM [ (installedPackageId p, packageConfigId p) + | p <- pkgs ] + + lookupIPID ipid@(InstalledPackageId str) + | Just pid <- lookupFM ipid_map ipid = return pid + | otherwise = missingPackageErr str + + preload2 <- mapM lookupIPID preload1 + + let -- add base & rts to the preload packages basicLinkedPackages | dopt Opt_AutoLinkPackages dflags @@ -566,19 +556,20 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do -- but in any case remove the current package from the set of -- preloaded packages so that base/rts does not end up in the -- set up preloaded package when we are just building it - preload2 = nub (filter (/= new_this_pkg) - (basicLinkedPackages ++ map mkPackageId preload1)) + preload3 = nub $ filter (/= this_package) + $ (basicLinkedPackages ++ preload2) -- Close the preload packages with their dependencies - dep_preload <- closeDeps pkg_db (zip preload2 (repeat Nothing)) + dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleMap pkg_db + moduleToPkgConfAll = mkModuleMap pkg_db, + installedPackageIdMap = ipid_map } - return (pstate, new_dep_preload, new_this_pkg) + return (pstate, new_dep_preload, this_package) -- ----------------------------------------------------------------------------- @@ -697,31 +688,39 @@ getPreloadPackagesAnd dflags pkgids = let state = pkgState dflags pkg_map = pkgIdMap state + ipid_map = installedPackageIdMap state preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do - all_pkgs <- throwErr (foldM (add_package pkg_map) preload pairs) + all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs) return (map (getPackageDetails state) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). -closeDeps :: PackageConfigMap -> [(PackageId, Maybe PackageId)] - -> IO [PackageId] -closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps) +closeDeps :: PackageConfigMap + -> FiniteMap InstalledPackageId PackageId + -> [(PackageId, Maybe PackageId)] + -> IO [PackageId] +closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) throwErr :: MaybeErr Message a -> IO a throwErr m = case m of Failed e -> ghcError (CmdLineError (showSDoc e)) Succeeded r -> return r -closeDepsErr :: PackageConfigMap -> [(PackageId,Maybe PackageId)] - -> MaybeErr Message [PackageId] -closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps +closeDepsErr :: PackageConfigMap + -> FiniteMap InstalledPackageId PackageId + -> [(PackageId,Maybe PackageId)] + -> MaybeErr Message [PackageId] +closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper -add_package :: PackageConfigMap -> [PackageId] -> (PackageId,Maybe PackageId) - -> MaybeErr Message [PackageId] -add_package pkg_db ps (p, mb_parent) +add_package :: PackageConfigMap + -> FiniteMap InstalledPackageId PackageId + -> [PackageId] + -> (PackageId,Maybe PackageId) + -> MaybeErr Message [PackageId] +add_package pkg_db ipid_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupPackage pkg_db p of @@ -729,11 +728,16 @@ add_package pkg_db ps (p, mb_parent) missingDependencyMsg mb_parent) Just pkg -> do -- Add the package's dependents also - let deps = map mkPackageId (depends pkg) - ps' <- foldM (add_package pkg_db) ps (zip deps (repeat (Just p))) + ps' <- foldM add_package_ipid ps (depends pkg) return (p : ps') + where + add_package_ipid ps ipid@(InstalledPackageId str) + | Just pid <- lookupFM ipid_map ipid + = add_package pkg_db ipid_map ps (pid, Just p) + | otherwise + = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent) -missingPackageErr :: String -> IO [PackageConfig] +missingPackageErr :: String -> IO a missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p))) missingPackageMsg :: String -> SDoc diff --git a/compiler/main/ParsePkgConf.y b/compiler/main/ParsePkgConf.y index 6028af8..d05a6d5 100644 --- a/compiler/main/ParsePkgConf.y +++ b/compiler/main/ParsePkgConf.y @@ -81,8 +81,12 @@ field :: { PackageConfig -> PackageConfig } _ -> happyError } } - | VARID '=' CONID STRING { id } - -- another case of license + | VARID '=' CONID STRING + { \p -> case unpackFS $1 of + "installedPackageId" -> + p{installedPackageId = InstalledPackageId (unpackFS $4)} + _ -> p -- another case of license + } | VARID '=' strlist {\p -> case unpackFS $1 of @@ -107,7 +111,7 @@ field :: { PackageConfig -> PackageConfig } _ -> p } - | VARID '=' pkgidlist + | VARID '=' ipidlist {% case unpackFS $1 of "depends" -> return (\p -> p{depends = $3}) _ -> happyError @@ -129,13 +133,20 @@ version :: { Version } { Version{ versionBranch=$5, versionTags=map unpackFS $9 } } -pkgidlist :: { [PackageIdentifier] } - : '[' pkgids ']' { $2 } +ipid :: { InstalledPackageId } + : CONID STRING + {% case unpackFS $1 of + "InstalledPackageId" -> return (InstalledPackageId (unpackFS $2)) + _ -> happyError + } + +ipidlist :: { [InstalledPackageId] } + : '[' ipids ']' { $2 } -- empty list case is covered by strlist, to avoid conflicts -pkgids :: { [PackageIdentifier] } - : pkgid { [ $1 ] } - | pkgid ',' pkgids { $1 : $3 } +ipids :: { [InstalledPackageId] } + : ipid { [ $1 ] } + | ipid ',' ipids { $1 : $3 } intlist :: { [Int] } : '[' ']' { [] } diff --git a/libffi/package.conf.in b/libffi/package.conf.in index eea9c40..649540f 100644 --- a/libffi/package.conf.in +++ b/libffi/package.conf.in @@ -1,5 +1,6 @@ name: ffi version: 1.0 +id: builtin:ffi license: BSD3 maintainer: glasgow-haskell-users@haskell.org exposed: True diff --git a/rts/package.conf.in b/rts/package.conf.in index 32bd00f..1112b99 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -5,6 +5,7 @@ name: rts version: 1.0 +id: builtin:rts license: BSD3 maintainer: glasgow-haskell-users@haskell.org exposed: True @@ -55,7 +56,7 @@ include-dirs: TOP"/includes" #endif includes: Stg.h -depends: ffi-1.0 +depends: builtin:ffi hugs-options: cc-options: diff --git a/utils/ghc-cabal/ghc-cabal.hs b/utils/ghc-cabal/ghc-cabal.hs index 8c9612f..8ee1304 100644 --- a/utils/ghc-cabal/ghc-cabal.hs +++ b/utils/ghc-cabal/ghc-cabal.hs @@ -25,6 +25,7 @@ import System.Directory import System.Environment import System.Exit import System.FilePath +import Data.Char main :: IO () main = do args <- getArgs @@ -208,9 +209,11 @@ generate config_args distdir directory (Nothing, Nothing) -> return () (Just lib, Just clbi) -> do cwd <- getCurrentDirectory + let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace") let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir pd lib lbi clbi - content = Installed.showInstalledPackageInfo installedPkgInfo ++ "\n" + final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid } + content = Installed.showInstalledPackageInfo final_ipi ++ "\n" writeFileAtomic (distdir "inplace-pkg-config") content _ -> error "Inconsistent lib components; can't happen?" @@ -242,16 +245,19 @@ generate config_args distdir directory -- stricter than gnu ld). Thus we remove the ldOptions for -- GHC's rts package: hackRtsPackage index = - case PackageIndex.lookupPackageName index (PackageName "rts") of - [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index + case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of + [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index _ -> error "No (or multiple) ghc rts package is registered!!" + dep_ids = map (packageId.getLocalPackageInfo lbi) $ + externalPackageDeps lbi + let variablePrefix = directory ++ '_':distdir let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), variablePrefix ++ "_MODULES = " ++ unwords (map display modules), variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi), - variablePrefix ++ "_DEPS = " ++ unwords (map display (externalPackageDeps lbi)), - variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (externalPackageDeps lbi)), + variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids), + variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids), variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi), variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi), variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi), diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index f79ebab..a13ba44 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,26 +1,21 @@ {-# OPTIONS -fglasgow-exts -cpp #-} ----------------------------------------------------------------------------- -- --- (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 qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ModuleName hiding (main) -import Distribution.InstalledPackageInfo hiding (depends) +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 @@ -192,6 +187,11 @@ usageHeader prog = substProg prog $ " 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" ++ @@ -230,7 +230,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"++ @@ -310,15 +310,17 @@ runit verbosity cli nonopts = do pkgid <- readGlobPkgId pkgid_str 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 @@ -544,11 +546,6 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do when (verbosity >= Normal) $ putStrLn "done." - let unversioned_deps = filter (not . realVersion) (depends pkg) - unless (null unversioned_deps) $ - die ("Unversioned dependencies found: " ++ - unwords (map display unversioned_deps)) - let truncated_stack = dropWhile ((/= to_modify).fst) db_stack -- truncate the stack for validation, because we don't allow -- packages lower in the stack to refer to those higher up. @@ -616,8 +613,10 @@ modifyPackage fn pkgid verbosity my_flags force = do -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () -listPackages my_flags mPackageName mModuleName = do +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, _) <- getPkgDatabases False my_flags let db_stack_filtered -- if a package is given, filter out all other packages @@ -642,23 +641,35 @@ listPackages my_flags mPackageName mModuleName = do match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) pkg_map = allPackagesInStack db_stack - show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map) + broken = map package (brokenPackages pkg_map) - show_func (reverse db_stack_sorted) + show_func = if simple_output then show_simple else mapM_ show_normal - where show_normal pkg_map (db_name,pkg_confs) = + show_normal (db_name,pkg_confs) = hPutStrLn stdout (render $ text db_name <> colon $$ nest 4 packages ) - where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) - broken = map package (brokenPackages pkg_map) + where packages + | verbosity >= Verbose = vcat (map pp_pkg pkg_confs) + | otherwise = fsep (punctuate comma (map pp_pkg pkg_confs)) pp_pkg p | package p `elem` broken = braces doc | exposed p = doc | otherwise = parens doc - where doc = text (display (package p)) + where doc | verbosity >= Verbose = pkg <+> parens ipid + | otherwise = pkg + where + InstalledPackageId ipid_str = installedPackageId p + ipid = text ipid_str + pkg = text (display (package p)) + + show_simple = simplePackageList my_flags . allPackagesInStack - show_simple = simplePackageList my_flags . allPackagesInStack + when (not (null broken) && verbosity /= Silent) $ do + prog <- getProgramName + putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") + + show_func (reverse db_stack_sorted) simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () simplePackageList my_flags pkgs = do @@ -668,6 +679,23 @@ simplePackageList my_flags pkgs = do when (not (null pkgs)) $ hPutStrLn stdout $ concat $ intersperse " " strs +showPackageDot :: Verbosity -> [Flag] -> IO () +showPackageDot _verbosity myflags = do + (db_stack, _) <- getPkgDatabases False myflags + let all_pkgs = allPackagesInStack db_stack + ipix = PackageIndex.listToInstalledPackageIndex all_pkgs + + putStrLn "digraph {" + let quote s = '"':s ++ "\"" + mapM_ putStrLn [ quote from ++ " -> " ++ quote to + | p <- all_pkgs, + let from = display (package p), + depid <- depends p, + Just dep <- [PackageIndex.lookupInstalledPackage ipix depid], + let to = display (package dep) + ] + putStrLn "}" + -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package @@ -720,6 +748,10 @@ 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 (display (package pkg)) @@ -851,7 +883,7 @@ closure pkgs db_stack = go pkgs db_stack -> Bool depsAvailable pkgs_ok pkg = null dangling where dangling = filter (`notElem` pids) (depends pkg) - pids = map package pkgs_ok + pids = map installedPackageId pkgs_ok -- we want mutually recursive groups of package to show up -- as broken. (#1750) @@ -954,6 +986,7 @@ checkPackageConfig :: InstalledPackageInfo -> 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 mapM_ (checkDep db_stack) (depends pkg) @@ -967,6 +1000,18 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do -- 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 @@ -1011,23 +1056,16 @@ checkDir thisfield d when (not there) $ verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") -checkDep :: PackageDBStack -> PackageIdentifier -> Validate () +checkDep :: PackageDBStack -> InstalledPackageId -> Validate () checkDep db_stack pkgid - | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = verror ForceAll ("dependency " ++ display pkgid - ++ " doesn't exist") + | 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 = allPackagesInStack db_stack - pkgids = map package all_pkgs + pkgids = map installedPackageId all_pkgs -checkDuplicateDepends :: [PackageIdentifier] -> Validate () +checkDuplicateDepends :: [InstalledPackageId] -> Validate () checkDuplicateDepends deps | null dups = return () | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ @@ -1035,9 +1073,6 @@ checkDuplicateDepends deps where dups = [ p | (p:_:_) <- group (sort deps) ] -realVersion :: PackageIdentifier -> Bool -realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] - checkHSLib :: [String] -> Bool -> String -> Validate () checkHSLib dirs auto_ghci_libs lib = do let batch_lib_file = "lib" ++ lib ++ ".a" -- 1.7.10.4