From 7d7108b05a3ba4596e99b5b834908b52658bff0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 13 Feb 2013 15:47:43 +0200 Subject: [PATCH] Global DB usage --- Stackage/GhcPkg.hs | 24 ++++++++++++++++++++++++ Stackage/InstallInfo.hs | 33 ++++++++++++++++++++++++++------- Stackage/NarrowDatabase.hs | 5 ++++- Stackage/Select.hs | 1 + Stackage/Types.hs | 4 ++++ app/stackage.hs | 4 ++++ stackage.cabal | 1 + 7 files changed, 64 insertions(+), 8 deletions(-) create mode 100644 Stackage/GhcPkg.hs diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs new file mode 100644 index 00000000..29335158 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,24 @@ +module Stackage.GhcPkg where + +import Stackage.Types +import System.Process +import Distribution.Text (simpleParse) +import Data.Char (isSpace) +import qualified Data.Set as Set + +getGlobalPackages :: IO (Set PackageIdentifier) +getGlobalPackages = do + output <- readProcess "ghc-pkg" ["--no-user-package-db", "list"] "" + fmap Set.unions $ mapM parse $ drop 1 $ lines output + where + parse s = + case clean s of + "" -> return Set.empty + s' -> + case simpleParse s' of + Just x -> return $ Set.singleton x + Nothing -> error $ "Could not parse ghc-pkg output: " ++ show s + clean = stripParens . dropWhile isSpace . reverse . dropWhile isSpace . reverse + stripParens x@('(':_:_) + | last x == ')' = tail $ init $ x + stripParens x = x diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs index 03afbacb..4b0f0f6a 100644 --- a/Stackage/InstallInfo.hs +++ b/Stackage/InstallInfo.hs @@ -9,12 +9,14 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Version (showVersion) import qualified Distribution.Text +import Distribution.Text (display) import Distribution.Version (simplifyVersionRange, withinRange) import Stackage.HaskellPlatform import Stackage.LoadDatabase import Stackage.NarrowDatabase import Stackage.Types import Stackage.Util +import Stackage.GhcPkg dropExcluded :: SelectSettings -> Map PackageName (VersionRange, Maintainer) @@ -26,22 +28,34 @@ getInstallInfo :: SelectSettings -> IO InstallInfo getInstallInfo settings = do putStrLn "Loading Haskell Platform" hp <- loadHaskellPlatform settings + + core <- + if useGlobalDatabase settings + then do + putStrLn "Loading core packages from global database" + getGlobalPackages + else return $ hpcore hp + let coreMap = Map.unions + $ map (\(PackageIdentifier k v) -> Map.singleton k v) + $ Set.toList core + let allPackages' | requireHaskellPlatform settings = Map.union (stablePackages settings) $ identsToRanges (hplibs hp) | otherwise = stablePackages settings allPackages = dropExcluded settings allPackages' - let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp) + let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core putStrLn "Loading package database" pdb <- loadPackageDB settings totalCore allPackages putStrLn "Narrowing package database" - final <- narrowPackageDB settings pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages + final <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages putStrLn "Printing build plan to build-plan.log" writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final - case checkBadVersions settings pdb final of + putStrLn "Checking for bad versions" + case checkBadVersions settings coreMap pdb final of badVersions | Map.null badVersions -> return () | otherwise -> do @@ -96,10 +110,11 @@ bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpP -- | Check for internal mismatches in required and actual package versions. checkBadVersions :: SelectSettings + -> Map PackageName Version -- ^ core -> PackageDB -> Map PackageName BuildInfo -> Map String (Map PackageName (Version, VersionRange)) -checkBadVersions settings (PackageDB pdb) buildPlan = +checkBadVersions settings core (PackageDB pdb) buildPlan = Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan where unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings @@ -123,9 +138,13 @@ checkBadVersions settings (PackageDB pdb) buildPlan = checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange) checkPackage name vr = case Map.lookup name buildPlan of - -- Can't find the dependency. Could be part of core, so just ignore - -- it. - Nothing -> Map.empty + Nothing -> + case Map.lookup name core of + -- Might be part of extra-core + Nothing -> Map.empty + Just version + | version `withinRange` vr -> Map.empty + | otherwise -> Map.singleton name (version, vr) Just bi | biVersion bi `withinRange` vr -> Map.empty | otherwise -> Map.singleton name (biVersion bi, vr) diff --git a/Stackage/NarrowDatabase.hs b/Stackage/NarrowDatabase.hs index 9dd1df23..9ef99188 100644 --- a/Stackage/NarrowDatabase.hs +++ b/Stackage/NarrowDatabase.hs @@ -7,14 +7,16 @@ import Prelude hiding (pi) import Stackage.Types import Stackage.Util import System.Exit (exitFailure) +import Distribution.Text (display) -- | Narrow down the database to only the specified packages and all of -- their dependencies. narrowPackageDB :: SelectSettings + -> Set PackageName -- ^ core packages to be excluded from installation -> PackageDB -> Set (PackageName, Maintainer) -> IO (Map PackageName BuildInfo) -narrowPackageDB settings (PackageDB pdb) packageSet = do +narrowPackageDB settings core (PackageDB pdb) packageSet = do (res, errs) <- runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet if Set.null errs then return res @@ -29,6 +31,7 @@ narrowPackageDB settings (PackageDB pdb) packageSet = do Just ((users, p, maintainer), toProcess') -> case Map.lookup p pdb of Nothing + | p `Set.member` core -> loop result toProcess' | null users -> error $ "Unknown package: " ++ show p | otherwise -> loop result toProcess' Just pi -> do diff --git a/Stackage/Select.hs b/Stackage/Select.hs index caf24c40..5858d71a 100644 --- a/Stackage/Select.hs +++ b/Stackage/Select.hs @@ -24,6 +24,7 @@ defaultSelectSettings = SelectSettings , excludedPackages = empty , flags = Set.fromList $ words "blaze_html_0_5" , allowedPackage = const $ Right () + , useGlobalDatabase = False } select :: SelectSettings -> IO BuildPlan diff --git a/Stackage/Types.hs b/Stackage/Types.hs index 41c57a52..554b1b32 100644 --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -108,6 +108,10 @@ data SelectSettings = SelectSettings -- even if present via the Haskell Platform or @stablePackages@. If these -- packages are dependencies of others, they will still be included. , stablePackages :: Map PackageName (VersionRange, Maintainer) + , useGlobalDatabase :: Bool + -- ^ Instead of checking the Haskell Platform file for core packages, query + -- the global database. For this to be reliable, you should only have + -- default packages in your global database. Default is @False@. } data BuildStage = BSBuild | BSTest diff --git a/app/stackage.hs b/app/stackage.hs index d80bbdb2..5624d8ce 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -18,6 +18,7 @@ data SelectArgs = SelectArgs , onlyPermissive :: Bool , allowed :: [String] , buildPlanDest :: FilePath + , globalDB :: Bool } parseSelectArgs :: [String] -> IO SelectArgs @@ -28,6 +29,7 @@ parseSelectArgs = , onlyPermissive = False , allowed = [] , buildPlanDest = defaultBuildPlan + , globalDB = False } where loop x [] = return x @@ -36,6 +38,7 @@ parseSelectArgs = loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest loop x ("--build-plan":y:rest) = loop x { buildPlanDest = y } rest + loop x ("--use-global-db":rest) = loop x { globalDB = True } rest loop _ (y:_) = error $ "Did not understand argument: " ++ y data BuildArgs = BuildArgs @@ -85,6 +88,7 @@ main = do if onlyPermissive then allowPermissive allowed else const $ Right () + , useGlobalDatabase = globalDB } writeBuildPlan buildPlanDest bp ("check":rest) -> withBuildSettings rest $ const checkPlan diff --git a/stackage.cabal b/stackage.cabal index 4a4173bd..53ad982c 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -27,6 +27,7 @@ library Stackage.BuildPlan Stackage.CheckCabalVersion Stackage.Select + Stackage.GhcPkg build-depends: base >= 4 && < 5 , containers , Cabal