7d7108b · stackage · git.iko.soy

git.iko.soy/stackage

Global DB usage

commit7d7108b05a3ba4596e99b5b834908b52658bff0d authorMichael Snoyman <michael@snoyman.com> dateWed 13 Feb 2013, 15:47 (14 years ago) parent77b4afc

7 files changed+64−8

compare with master

unifiedsplit

Stackage/GhcPkg.hs+24 Stackage/InstallInfo.hs+26−7 Stackage/NarrowDatabase.hs+4−1 Stackage/Select.hs+1 Stackage/Types.hs+4 app/stackage.hs+4 stackage.cabal+1

Stackage/GhcPkg.hsnew file+24

@@ -0,0 +1,24 @@

1+module Stackage.GhcPkg where

3+import Stackage.Types

4+import System.Process

5+import Distribution.Text (simpleParse)

6+import Data.Char (isSpace)

7+import qualified Data.Set as Set

9+getGlobalPackages :: IO (Set PackageIdentifier)

10+getGlobalPackages = do

11+ output <- readProcess "ghc-pkg" ["--no-user-package-db", "list"] ""

12+ fmap Set.unions $ mapM parse $ drop 1 $ lines output

13+ where

14+ parse s =

15+ case clean s of

16+ "" -> return Set.empty

17+ s' ->

18+ case simpleParse s' of

19+ Just x -> return $ Set.singleton x

20+ Nothing -> error $ "Could not parse ghc-pkg output: " ++ show s

21+ clean = stripParens . dropWhile isSpace . reverse . dropWhile isSpace . reverse

22+ stripParens x@('(':_:_)

23+ | last x == ')' = tail $ init $ x

24+ stripParens x = x

Stackage/InstallInfo.hs+26−7

@@ -9,12 +9,14 @@ import qualified Data.Map as Map

99import qualified Data.Set as Set

1010import Data.Version (showVersion)

1111import qualified Distribution.Text

12+import Distribution.Text (display)

1213import Distribution.Version (simplifyVersionRange, withinRange)

1314import Stackage.HaskellPlatform

1415import Stackage.LoadDatabase

1516import Stackage.NarrowDatabase

1617import Stackage.Types

1718import Stackage.Util

19+import Stackage.GhcPkg

1820

1921dropExcluded :: SelectSettings

2022 -> Map PackageName (VersionRange, Maintainer)

@@ -26,22 +28,34 @@ getInstallInfo :: SelectSettings -> IO InstallInfo

2628getInstallInfo settings = do

2729 putStrLn "Loading Haskell Platform"

2830 hp <- loadHaskellPlatform settings

31+

32+ core <-

33+ if useGlobalDatabase settings

34+ then do

35+ putStrLn "Loading core packages from global database"

36+ getGlobalPackages

37+ else return $ hpcore hp

38+ let coreMap = Map.unions

39+ $ map (\(PackageIdentifier k v) -> Map.singleton k v)

40+ $ Set.toList core

41+

2942 let allPackages'

3043 | requireHaskellPlatform settings = Map.union (stablePackages settings) $ identsToRanges (hplibs hp)

3144 | otherwise = stablePackages settings

3245 allPackages = dropExcluded settings allPackages'

33− let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)

46+ let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core

3447

3548 putStrLn "Loading package database"

3649 pdb <- loadPackageDB settings totalCore allPackages

3750

3851 putStrLn "Narrowing package database"

39− final <- narrowPackageDB settings pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages

52+ final <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages

4053

4154 putStrLn "Printing build plan to build-plan.log"

4255 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final

4356

44− case checkBadVersions settings pdb final of

57+ putStrLn "Checking for bad versions"

58+ case checkBadVersions settings coreMap pdb final of

4559 badVersions

4660 | Map.null badVersions -> return ()

4761 | otherwise -> do

@@ -96,10 +110,11 @@ bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpP

96110

97111-- | Check for internal mismatches in required and actual package versions.

98112checkBadVersions :: SelectSettings

113+ -> Map PackageName Version -- ^ core

99114 -> PackageDB

100115 -> Map PackageName BuildInfo

101116 -> Map String (Map PackageName (Version, VersionRange))

102−checkBadVersions settings (PackageDB pdb) buildPlan =

117+checkBadVersions settings core (PackageDB pdb) buildPlan =

103118 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan

104119 where

105120 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings

@@ -123,9 +138,13 @@ checkBadVersions settings (PackageDB pdb) buildPlan =

123138 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)

124139 checkPackage name vr =

125140 case Map.lookup name buildPlan of

126− -- Can't find the dependency. Could be part of core, so just ignore

127− -- it.

128− Nothing -> Map.empty

141+ Nothing ->

142+ case Map.lookup name core of

143+ -- Might be part of extra-core

144+ Nothing -> Map.empty

145+ Just version

146+ | version `withinRange` vr -> Map.empty

147+ | otherwise -> Map.singleton name (version, vr)

129148 Just bi

130149 | biVersion bi `withinRange` vr -> Map.empty

131150 | otherwise -> Map.singleton name (biVersion bi, vr)

Stackage/NarrowDatabase.hs+4−1

@@ -7,14 +7,16 @@ import Prelude hiding (pi)

77import Stackage.Types

88import Stackage.Util

99import System.Exit (exitFailure)

10+import Distribution.Text (display)

1011

1112-- | Narrow down the database to only the specified packages and all of

1213-- their dependencies.

1314narrowPackageDB :: SelectSettings

15+ -> Set PackageName -- ^ core packages to be excluded from installation

1416 -> PackageDB

1517 -> Set (PackageName, Maintainer)

1618 -> IO (Map PackageName BuildInfo)

17−narrowPackageDB settings (PackageDB pdb) packageSet = do

19+narrowPackageDB settings core (PackageDB pdb) packageSet = do

1820 (res, errs) <- runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet

1921 if Set.null errs

2022 then return res

@@ -29,6 +31,7 @@ narrowPackageDB settings (PackageDB pdb) packageSet = do

2931 Just ((users, p, maintainer), toProcess') ->

3032 case Map.lookup p pdb of

3133 Nothing

34+ | p `Set.member` core -> loop result toProcess'

3235 | null users -> error $ "Unknown package: " ++ show p

3336 | otherwise -> loop result toProcess'

3437 Just pi -> do

Stackage/Select.hs+1

@@ -24,6 +24,7 @@ defaultSelectSettings = SelectSettings

2424 , excludedPackages = empty

2525 , flags = Set.fromList $ words "blaze_html_0_5"

2626 , allowedPackage = const $ Right ()

27+ , useGlobalDatabase = False

2728 }

2829

2930select :: SelectSettings -> IO BuildPlan

Stackage/Types.hs+4

@@ -108,6 +108,10 @@ data SelectSettings = SelectSettings

108108 -- even if present via the Haskell Platform or @stablePackages@. If these

109109 -- packages are dependencies of others, they will still be included.

110110 , stablePackages :: Map PackageName (VersionRange, Maintainer)

111+ , useGlobalDatabase :: Bool

112+ -- ^ Instead of checking the Haskell Platform file for core packages, query

113+ -- the global database. For this to be reliable, you should only have

114+ -- default packages in your global database. Default is @False@.

111115 }

112116

113117data BuildStage = BSBuild | BSTest

app/stackage.hs+4

@@ -18,6 +18,7 @@ data SelectArgs = SelectArgs

1818 , onlyPermissive :: Bool

1919 , allowed :: [String]

2020 , buildPlanDest :: FilePath

21+ , globalDB :: Bool

2122 }

2223

2324parseSelectArgs :: [String] -> IO SelectArgs

@@ -28,6 +29,7 @@ parseSelectArgs =

2829 , onlyPermissive = False

2930 , allowed = []

3031 , buildPlanDest = defaultBuildPlan

32+ , globalDB = False

3133 }

3234 where

3335 loop x [] = return x

@@ -36,6 +38,7 @@ parseSelectArgs =

3638 loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest

3739 loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest

3840 loop x ("--build-plan":y:rest) = loop x { buildPlanDest = y } rest

41+ loop x ("--use-global-db":rest) = loop x { globalDB = True } rest

3942 loop _ (y:_) = error $ "Did not understand argument: " ++ y

4043

4144data BuildArgs = BuildArgs

@@ -85,6 +88,7 @@ main = do

8588 if onlyPermissive

8689 then allowPermissive allowed

8790 else const $ Right ()

91+ , useGlobalDatabase = globalDB

8892 }

8993 writeBuildPlan buildPlanDest bp

9094 ("check":rest) -> withBuildSettings rest $ const checkPlan

stackage.cabal+1

@@ -27,6 +27,7 @@ library

2727 Stackage.BuildPlan

2828 Stackage.CheckCabalVersion

2929 Stackage.Select

30+ Stackage.GhcPkg

3031 build-depends: base >= 4 && < 5

3132 , containers

3233 , Cabal