7d7108b · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

Global DB usage

7d7108bMichael Snoyman14 years ago

Stackage/GhcPkg.hsnew file+24

compare with master

unifiedsplit

@@ -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

9import qualified Data.Set as Set

10import Data.Version (showVersion)

11import qualified Distribution.Text

12+import Distribution.Text (display)

12import Distribution.Version (simplifyVersionRange, withinRange)

13import Distribution.Version (simplifyVersionRange, withinRange)

13import Stackage.HaskellPlatform

14import Stackage.HaskellPlatform

14import Stackage.LoadDatabase

15import Stackage.LoadDatabase

15import Stackage.NarrowDatabase

16import Stackage.NarrowDatabase

16import Stackage.Types

17import Stackage.Types

17import Stackage.Util

18import Stackage.Util

19+import Stackage.GhcPkg

19dropExcluded :: SelectSettings

21dropExcluded :: SelectSettings

20 -> Map PackageName (VersionRange, Maintainer)

22 -> Map PackageName (VersionRange, Maintainer)

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

26getInstallInfo settings = do

28getInstallInfo settings = do

27 putStrLn "Loading Haskell Platform"

29 putStrLn "Loading Haskell Platform"

28 hp <- loadHaskellPlatform settings

30 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+

29 let allPackages'

42 let allPackages'

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

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

31 | otherwise = stablePackages settings

44 | otherwise = stablePackages settings

32 allPackages = dropExcluded settings allPackages'

45 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

35 putStrLn "Loading package database"

48 putStrLn "Loading package database"

36 pdb <- loadPackageDB settings totalCore allPackages

49 pdb <- loadPackageDB settings totalCore allPackages

38 putStrLn "Narrowing package database"

51 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

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

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

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

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

57+ putStrLn "Checking for bad versions"

44− case checkBadVersions settings pdb final of

58+ case checkBadVersions settings coreMap pdb final of

45 badVersions

59 badVersions

46 | Map.null badVersions -> return ()

60 | Map.null badVersions -> return ()

47 | otherwise -> do

61 | otherwise -> do

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

110

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

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

98checkBadVersions :: SelectSettings

112checkBadVersions :: SelectSettings

113+ -> Map PackageName Version -- ^ core

99 -> PackageDB

114 -> PackageDB

100 -> Map PackageName BuildInfo

115 -> Map PackageName BuildInfo

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

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

102−checkBadVersions settings (PackageDB pdb) buildPlan =

117+checkBadVersions settings core (PackageDB pdb) buildPlan =

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

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

104 where

119 where

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

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

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

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

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

124 checkPackage name vr =

139 checkPackage name vr =

125 case Map.lookup name buildPlan of

140 case Map.lookup name buildPlan of

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

141+ Nothing ->

127− -- it.

142+ case Map.lookup name core of

128− Nothing -> Map.empty

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)

129 Just bi

148 Just bi

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

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

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

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

Stackage/NarrowDatabase.hs+4−1

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

7import Stackage.Types

8import Stackage.Util

9import System.Exit (exitFailure)

10+import Distribution.Text (display)

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

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

12-- their dependencies.

13-- their dependencies.

13narrowPackageDB :: SelectSettings

14narrowPackageDB :: SelectSettings

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

14 -> PackageDB

16 -> PackageDB

15 -> Set (PackageName, Maintainer)

17 -> Set (PackageName, Maintainer)

16 -> IO (Map PackageName BuildInfo)

18 -> IO (Map PackageName BuildInfo)

17−narrowPackageDB settings (PackageDB pdb) packageSet = do

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

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

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

19 if Set.null errs

21 if Set.null errs

20 then return res

22 then return res

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

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

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

30 case Map.lookup p pdb of

32 case Map.lookup p pdb of

31 Nothing

33 Nothing

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

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

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

33 | otherwise -> loop result toProcess'

36 | otherwise -> loop result toProcess'

34 Just pi -> do

37 Just pi -> do

Stackage/Select.hs+1

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

24 , excludedPackages = empty

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

26 , allowedPackage = const $ Right ()

27+ , useGlobalDatabase = False

27 }

28 }

29select :: SelectSettings -> IO BuildPlan

30select :: SelectSettings -> IO BuildPlan

Stackage/Types.hs+4

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

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

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

110 , 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@.

111 }

115 }

112

116

113data BuildStage = BSBuild | BSTest

117data BuildStage = BSBuild | BSTest

app/stackage.hs+4

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

18 , onlyPermissive :: Bool

19 , allowed :: [String]

20 , buildPlanDest :: FilePath

21+ , globalDB :: Bool

21 }

22 }

23parseSelectArgs :: [String] -> IO SelectArgs

24parseSelectArgs :: [String] -> IO SelectArgs

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

28 , onlyPermissive = False

29 , onlyPermissive = False

29 , allowed = []

30 , allowed = []

30 , buildPlanDest = defaultBuildPlan

31 , buildPlanDest = defaultBuildPlan

32+ , globalDB = False

31 }

33 }

32 where

34 where

33 loop x [] = return x

35 loop x [] = return x

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

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

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

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

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

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

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

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

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

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

41data BuildArgs = BuildArgs

44data BuildArgs = BuildArgs

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

85 if onlyPermissive

88 if onlyPermissive

86 then allowPermissive allowed

89 then allowPermissive allowed

87 else const $ Right ()

90 else const $ Right ()

91+ , useGlobalDatabase = globalDB

88 }

92 }

89 writeBuildPlan buildPlanDest bp

93 writeBuildPlan buildPlanDest bp

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

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

stackage.cabal+1

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

27 Stackage.BuildPlan

28 Stackage.CheckCabalVersion

29 Stackage.Select

30+ Stackage.GhcPkg

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

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

31 , containers

32 , containers

32 , Cabal

33 , Cabal