3ccc779 · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

Update build plans

3ccc779Michael Snoyman12 years ago

Stackage2/BuildPlan.hs+38−7

compare with master

unifiedsplit

@@ -17,7 +17,7 @@ module Stackage2.BuildPlan

18import Distribution.Package (Dependency (..))

19import Distribution.PackageDescription

20−import Distribution.Version (withinRange, intersectVersionRanges)

20+import Distribution.Version (withinRange, anyVersion, simplifyVersionRange)

21import Stackage2.PackageConstraints

22import Stackage2.PackageIndex

23import Stackage2.Prelude

@@ -32,6 +32,10 @@ import qualified Distribution.Compiler

33data BuildPlan desc = BuildPlan

34 { bpCore :: Map PackageName Version

35+ , bpCoreExecutables :: Set ExeName

36+ , bpGhcVersion :: Version

37+ , bpOS :: Distribution.System.OS

38+ , bpArch :: Distribution.System.Arch

35 , bpTools :: Vector (PackageName, Version)

39 , bpTools :: Vector (PackageName, Version)

36 , bpExtra :: Map PackageName (PackageBuild desc)

40 , bpExtra :: Map PackageName (PackageBuild desc)

37 }

41 }

@@ -44,6 +48,10 @@ instance MonoTraversable (BuildPlan desc)

44instance ToJSON (BuildPlan desc) where

48instance ToJSON (BuildPlan desc) where

45 toJSON BuildPlan {..} = object

49 toJSON BuildPlan {..} = object

46 [ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)

50 [ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)

51+ , "core-exes" .= bpCoreExecutables

52+ , "ghc-version" .= asText (display bpGhcVersion)

53+ , "os" .= asText (display bpOS)

54+ , "arch" .= asText (display bpArch)

47 , "tools" .= map goTool bpTools

55 , "tools" .= map goTool bpTools

48 , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra

56 , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra

49 ]

57 ]

@@ -54,10 +62,15 @@ instance ToJSON (BuildPlan desc) where

54 , "version" .= asText (display version)

62 , "version" .= asText (display version)

55 ]

63 ]

56instance desc ~ () => FromJSON (BuildPlan desc) where

64instance desc ~ () => FromJSON (BuildPlan desc) where

57− parseJSON = withObject "BuildPlan" $ \o -> BuildPlan

65+ parseJSON = withObject "BuildPlan" $ \o -> do

58− <$> ((o .: "core") >>= goCore)

66+ bpCore <- (o .: "core") >>= goCore

67+ bpCoreExecutables <- o .: "core-exes"

68+ bpGhcVersion <- (o .: "ghc-version") >>= either (fail . show) return . simpleParse . asText

69+ bpOS <- o .: "os" >>= either (fail . show) return . simpleParse . asText

70+ bpArch <- (o .: "arch") >>= either (fail . show) return . simpleParse . asText

59− <*> ((o .: "tools") >>= mapM goTool)

71+ bpTools <- (o .: "tools") >>= mapM goTool

60− <*> (goExtra <$> (o .: "extra"))

72+ bpExtra <- goExtra <$> (o .: "extra")

73+ return BuildPlan {..}

61 where

74 where

62 goCore =

75 goCore =

63 fmap mapFromList . mapM goCore' . mapToList . asHashMap

76 fmap mapFromList . mapM goCore' . mapToList . asHashMap

@@ -77,6 +90,8 @@ instance desc ~ () => FromJSON (BuildPlan desc) where

78data PackageBuild desc = PackageBuild

91data PackageBuild desc = PackageBuild

79 { pbVersion :: Version

92 { pbVersion :: Version

93+ , pbVersionRange :: VersionRange

94+ -- ^ This is vital for ensuring old constraints are kept in place when bumping

80 , pbMaintainer :: Maybe Maintainer

95 , pbMaintainer :: Maybe Maintainer

81 , pbGithubPings :: Set Text

96 , pbGithubPings :: Set Text

82 , pbUsers :: Set PackageName

97 , pbUsers :: Set PackageName

@@ -92,11 +107,21 @@ instance MonoFunctor (PackageBuild desc)

92instance MonoFoldable (PackageBuild desc)

107instance MonoFoldable (PackageBuild desc)

93instance MonoTraversable (PackageBuild desc)

108instance MonoTraversable (PackageBuild desc)

109

110+-- | There seems to be a bug in Cabal where serializing and deserializing

111+-- version ranges winds up with different representations. So we have a

112+-- super-simplifier to deal with that.

113+superSimplifyVersionRange :: VersionRange -> VersionRange

114+superSimplifyVersionRange vr =

115+ fromMaybe (assert False vr') $ simpleParse $ asList $ display vr'

116+ where

117+ vr' = simplifyVersionRange vr

118+

95instance ToJSON (PackageBuild desc) where

119instance ToJSON (PackageBuild desc) where

96 toJSON PackageBuild {..} = object $ concat

120 toJSON PackageBuild {..} = object $ concat

97 [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer

121 [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer

98 ,

122 ,

99 [ "version" .= asText (display pbVersion)

123 [ "version" .= asText (display pbVersion)

124+ , "version-range" .= asText (display $ superSimplifyVersionRange pbVersionRange)

100 , "github-pings" .= pbGithubPings

125 , "github-pings" .= pbGithubPings

101 , "users" .= map unPackageName (unpack pbUsers)

126 , "users" .= map unPackageName (unpack pbUsers)

102 , "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags

127 , "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags

@@ -108,6 +133,7 @@ instance ToJSON (PackageBuild desc) where

108instance desc ~ () => FromJSON (PackageBuild desc) where

133instance desc ~ () => FromJSON (PackageBuild desc) where

109 parseJSON = withObject "PackageBuild" $ \o -> PackageBuild

134 parseJSON = withObject "PackageBuild" $ \o -> PackageBuild

110 <$> (o .: "version" >>= efail . simpleParse . asText)

135 <$> (o .: "version" >>= efail . simpleParse . asText)

136+ <*> (o .: "version-range" >>= fmap superSimplifyVersionRange . efail . simpleParse . asText)

111 <*> o .:? "maintainer"

137 <*> o .:? "maintainer"

112 <*> o .:? "github-pings" .!= mempty

138 <*> o .:? "github-pings" .!= mempty

113 <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))

139 <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))

@@ -137,7 +163,10 @@ newBuildPlan pc = liftIO $ do

137 -- FIXME topologically sort packages? maybe just leave that to the build phase

163 -- FIXME topologically sort packages? maybe just leave that to the build phase

138 return BuildPlan

164 return BuildPlan

139 { bpCore = pcCorePackages pc

165 { bpCore = pcCorePackages pc

140− -- bpCoreExes = pcCoreExecutables pc

166+ , bpCoreExecutables = pcCoreExecutables pc

167+ , bpGhcVersion = pcGhcVersion pc

168+ , bpOS = pcOS pc

169+ , bpArch = pcArch pc

141 , bpTools = tools

170 , bpTools = tools

142 , bpExtra = extra

171 , bpExtra = extra

143 }

172 }

@@ -253,7 +282,9 @@ mkPackageBuild pc gpd = do

253 gpd

282 gpd

254 return PackageBuild

283 return PackageBuild

255 { pbVersion = version

284 { pbVersion = version

256− , pbMaintainer = fmap snd $ lookup name $ pcPackages pc

285+ , pbVersionRange = superSimplifyVersionRange

286+ $ maybe anyVersion fst $ lookup name $ pcPackages pc

287+ , pbMaintainer = lookup name (pcPackages pc) >>= snd

257 , pbGithubPings = getGithubPings gpd

288 , pbGithubPings = getGithubPings gpd

258 , pbUsers = mempty -- must be filled in later

289 , pbUsers = mempty -- must be filled in later

259 , pbFlags = flags

290 , pbFlags = flags

Stackage2/PackageConstraints.hs+7−5

@@ -39,18 +39,20 @@ instance FromJSON TestState where

39 $ map (\x -> (testStateToText x, x)) [minBound..maxBound]

41data PackageConstraints = PackageConstraints

42− { pcPackages :: Map PackageName (VersionRange, Maintainer)

42+ { pcPackages :: Map PackageName (VersionRange, Maybe Maintainer)

43 -- ^ This does not include core packages or dependencies, just packages

44 -- added by some maintainer.

45 , pcGhcVersion :: Version

46 , pcOS :: OS

47 , pcArch :: Arch

48− , pcFlagOverrides :: PackageName -> Map FlagName Bool

48+ , pcCorePackages :: Map PackageName Version

49+ , pcCoreExecutables :: Set ExeName

50+

51+ -- Have a single lookup function with all of the package-specific stuff?

49 , pcTests :: PackageName -> TestState

52 , pcTests :: PackageName -> TestState

50 , pcHaddocks :: PackageName -> TestState

53 , pcHaddocks :: PackageName -> TestState

51 , pcBuildBenchmark :: PackageName -> Bool

54 , pcBuildBenchmark :: PackageName -> Bool

52− , pcCorePackages :: Map PackageName Version

55+ , pcFlagOverrides :: PackageName -> Map FlagName Bool

53− , pcCoreExecutables :: Set ExeName

54 }

56 }

56-- | The proposed plan from the requirements provided by contributors.

58-- | The proposed plan from the requirements provided by contributors.

@@ -78,7 +80,7 @@ defaultPackageConstraints = do

78 old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings

80 old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings

80 return PackageConstraints

82 return PackageConstraints

81− { pcPackages = fmap (Maintainer . pack . Old.unMaintainer)

83+ { pcPackages = fmap (Just . Maintainer . pack . Old.unMaintainer)

82 <$> Old.defaultStablePackages oldGhcVer False

84 <$> Old.defaultStablePackages oldGhcVer False

83 , pcCorePackages = core

85 , pcCorePackages = core

84 , pcCoreExecutables = coreExes

86 , pcCoreExecutables = coreExes

Stackage2/PackageDescription.hs+3−3

@@ -41,11 +41,11 @@ instance Monoid SimpleTree where

41 (b ++ y)

42 (c ++ z)

44−data SimpleExtra = SimpleExtra

44+data SimpleExtra = SimpleExtra -- FIXME fold into FlatComponent?

45 { seTools :: Map ExeName VersionRange

46 , seProvidedExes :: Set ExeName

47 }

48− deriving Show

48+ deriving (Show, Eq)

49instance Monoid SimpleExtra where

50 mempty = SimpleExtra mempty mempty

51 mappend (SimpleExtra a b) (SimpleExtra x y) = SimpleExtra

@@ -102,7 +102,7 @@ data FlatComponent = FlatComponent

102 { fcDeps :: Map PackageName VersionRange

103 , fcExtra :: SimpleExtra

104 }

105− deriving Show

105+ deriving (Show, Eq)

106instance Monoid FlatComponent where

107 mempty = FlatComponent mempty mempty

108 mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent

Stackage2/Prelude.hs+1−1

@@ -79,7 +79,7 @@ withCheckedProcess cp f = do

79 return res

81newtype Maintainer = Maintainer { unMaintainer :: Text }

82− deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON)

82+ deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)

84-- | Name of an executable.

85newtype ExeName = ExeName { unExeName :: Text }

Stackage2/UpdateBuildPlan.hsnew file+42

@@ -0,0 +1,42 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RecordWildCards #-}

4+-- | Take an existing build plan and bump all packages to the newest version in

5+-- the same major version number.

6+module Stackage2.UpdateBuildPlan

7+ ( updatePackageConstraints

8+ , updateBuildPlan

9+ ) where

10+

11+import Stackage2.Prelude

12+import Stackage2.BuildPlan

13+import Stackage2.PackageConstraints

14+import Stackage2.PackageDescription

15+import Distribution.Version (orLaterVersion, earlierVersion)

16+

17+updateBuildPlan :: BuildPlan a -> IO (BuildPlan FlatComponent)

18+updateBuildPlan = newBuildPlan . updatePackageConstraints

19+

20+updatePackageConstraints :: BuildPlan a -> PackageConstraints

21+updatePackageConstraints BuildPlan {..} = PackageConstraints

22+ { pcPackages = flip map bpExtra $ \pb ->

23+ ( intersectVersionRanges (bumpRange (pbVersion pb)) (pbVersionRange pb)

24+ , pbMaintainer pb

25+ )

26+ , pcCorePackages = bpCore

27+ , pcCoreExecutables = bpCoreExecutables

28+ , pcGhcVersion = bpGhcVersion

29+ , pcOS = bpOS

30+ , pcArch = bpArch

31+ , pcTests = maybe ExpectSuccess pbTestState . flip lookup bpExtra

32+ , pcHaddocks = maybe ExpectSuccess pbHaddockState . flip lookup bpExtra

33+ , pcBuildBenchmark = maybe True pbTryBuildBenchmark . flip lookup bpExtra

34+ , pcFlagOverrides = maybe mempty pbFlags . flip lookup bpExtra

35+ }

36+ where

37+ bumpRange version = intersectVersionRanges

38+ (orLaterVersion version)

39+ (earlierVersion $ bumpVersion version)

40+ bumpVersion (Version (x:y:_) _) = Version [x, y + 1] []

41+ bumpVersion (Version [x] _) = Version [x, 1] []

42+ bumpVersion (Version [] _) = assert False $ Version [1, 0] []

stackage.cabal+2

@@ -37,6 +37,7 @@ library

37 Stackage2.PackageIndex

38 Stackage2.BuildPlan

39 Stackage2.CheckBuildPlan

40+ Stackage2.UpdateBuildPlan

40 Stackage2.GithubPings

41 Stackage2.GithubPings

41 Stackage2.PackageDescription

42 Stackage2.PackageDescription

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

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

@@ -84,6 +85,7 @@ test-suite spec

84 , classy-prelude-conduit

85 , classy-prelude-conduit

85 , Cabal

86 , Cabal

86 , yaml

87 , yaml

88+ , containers

88source-repository head

90source-repository head

89 type: git

91 type: git

test/Stackage2/BuildPlanSpec.hs+20−1

@@ -4,13 +4,32 @@ module Stackage2.BuildPlanSpec (spec) where

4import Stackage2.BuildPlan

5import Stackage2.Prelude

6import Stackage2.PackageConstraints

7+import Stackage2.UpdateBuildPlan

7import Test.Hspec

8import Test.Hspec

8import qualified Data.Yaml as Y

9import qualified Data.Yaml as Y

9import Control.Exception (evaluate)

10import Control.Exception (evaluate)

11+import Distribution.Version (anyVersion)

12+import qualified Data.Map as Map

11spec :: Spec

14spec :: Spec

12spec = it "works" $ do

15spec = it "works" $ do

16+ pc <- defaultPackageConstraints

13− bp <- defaultPackageConstraints >>= newBuildPlan

17+ bp <- newBuildPlan pc

14 let bs = Y.encode bp

18 let bs = Y.encode bp

15 mbp' = Y.decode bs

19 mbp' = Y.decode bs

20+

21+ bp' <- maybe (error "decoding failed") return mbp'

22+

23+ let allPackages = Map.keysSet (bpExtra bp) ++ Map.keysSet (bpExtra bp')

24+ forM_ allPackages $ \name ->

25+ (name, lookup name (bpExtra bp')) `shouldBe`

26+ (name, lookup name (bpExtra $ () <$ bp))

27+

16 mbp' `shouldBe` Just (() <$ bp)

28 mbp' `shouldBe` Just (() <$ bp)

29+ bp2 <- newBuildPlan $ updatePackageConstraints bp

30+ dropVersionRanges bp2 `shouldBe` dropVersionRanges bp

31+ where

32+ dropVersionRanges bp =

33+ bp { bpExtra = map go $ bpExtra bp }

34+ where

35+ go pb = pb { pbVersionRange = anyVersion }