Update build plans

Stackage2/BuildPlan.hs

@@ -17,7 +17,7 @@ module Stackage2.BuildPlan
 
 import Distribution.Package            (Dependency (..))
 import Distribution.PackageDescription
-import Distribution.Version            (withinRange, intersectVersionRanges)
+import Distribution.Version            (withinRange, anyVersion, simplifyVersionRange)
 import Stackage2.PackageConstraints
 import Stackage2.PackageIndex
 import Stackage2.Prelude
@@ -32,6 +32,10 @@ import qualified Distribution.Compiler
 
 data BuildPlan desc = BuildPlan
     { bpCore        :: Map PackageName Version
+    , bpCoreExecutables :: Set ExeName
+    , bpGhcVersion :: Version
+    , bpOS :: Distribution.System.OS
+    , bpArch :: Distribution.System.Arch
     , bpTools       :: Vector (PackageName, Version)
     , bpExtra       :: Map PackageName (PackageBuild desc)
     }
@@ -44,6 +48,10 @@ instance MonoTraversable (BuildPlan desc)
 instance ToJSON (BuildPlan desc) where
     toJSON BuildPlan {..} = object
         [ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)
+        , "core-exes" .= bpCoreExecutables
+        , "ghc-version" .= asText (display bpGhcVersion)
+        , "os" .= asText (display bpOS)
+        , "arch" .= asText (display bpArch)
         , "tools" .= map goTool bpTools
         , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra
         ]
@@ -54,10 +62,15 @@ instance ToJSON (BuildPlan desc) where
             , "version" .= asText (display version)
             ]
 instance desc ~ () => FromJSON (BuildPlan desc) where
-    parseJSON = withObject "BuildPlan" $ \o -> BuildPlan
+    parseJSON = withObject "BuildPlan" $ \o -> do
-        <$> ((o .: "core") >>= goCore)
+        bpCore <- (o .: "core") >>= goCore
-        <*> ((o .: "tools") >>= mapM goTool)
+        bpCoreExecutables <- o .: "core-exes"
-        <*> (goExtra <$> (o .: "extra"))
+        bpGhcVersion <- (o .: "ghc-version") >>= either (fail . show) return . simpleParse . asText
+        bpOS <- o .: "os" >>= either (fail . show) return . simpleParse . asText
+        bpArch <- (o .: "arch") >>= either (fail . show) return . simpleParse . asText
+        bpTools <- (o .: "tools") >>= mapM goTool
+        bpExtra <- goExtra <$> (o .: "extra")
+        return BuildPlan {..}
       where
         goCore =
             fmap mapFromList . mapM goCore' . mapToList . asHashMap
@@ -77,6 +90,8 @@ instance desc ~ () => FromJSON (BuildPlan desc) where
 
 data PackageBuild desc = PackageBuild
     { pbVersion           :: Version
+    , pbVersionRange      :: VersionRange
+    -- ^ This is vital for ensuring old constraints are kept in place when bumping
     , pbMaintainer        :: Maybe Maintainer
     , pbGithubPings       :: Set Text
     , pbUsers             :: Set PackageName
@@ -92,11 +107,21 @@ instance MonoFunctor (PackageBuild desc)
 instance MonoFoldable (PackageBuild desc)
 instance MonoTraversable (PackageBuild desc)
 
+-- | There seems to be a bug in Cabal where serializing and deserializing
+-- version ranges winds up with different representations. So we have a
+-- super-simplifier to deal with that.
+superSimplifyVersionRange :: VersionRange -> VersionRange
+superSimplifyVersionRange vr =
+    fromMaybe (assert False vr') $ simpleParse $ asList $ display vr'
+  where
+    vr' = simplifyVersionRange vr
+
 instance ToJSON (PackageBuild desc) where
     toJSON PackageBuild {..} = object $ concat
         [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer
         ,
             [ "version" .= asText (display pbVersion)
+            , "version-range" .= asText (display $ superSimplifyVersionRange pbVersionRange)
             , "github-pings" .= pbGithubPings
             , "users" .= map unPackageName (unpack pbUsers)
             , "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags
@@ -108,6 +133,7 @@ instance ToJSON (PackageBuild desc) where
 instance desc ~ () => FromJSON (PackageBuild desc) where
     parseJSON = withObject "PackageBuild" $ \o -> PackageBuild
         <$> (o .: "version" >>= efail . simpleParse . asText)
+        <*> (o .: "version-range" >>= fmap superSimplifyVersionRange . efail . simpleParse . asText)
         <*> o .:? "maintainer"
         <*> o .:? "github-pings" .!= mempty
         <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))
@@ -137,7 +163,10 @@ newBuildPlan pc = liftIO $ do
     -- FIXME topologically sort packages? maybe just leave that to the build phase
     return BuildPlan
         { bpCore = pcCorePackages pc
-        -- bpCoreExes = pcCoreExecutables pc
+        , bpCoreExecutables = pcCoreExecutables pc
+        , bpGhcVersion = pcGhcVersion pc
+        , bpOS = pcOS pc
+        , bpArch = pcArch pc
         , bpTools = tools
         , bpExtra = extra
         }
@@ -253,7 +282,9 @@ mkPackageBuild pc gpd = do
         gpd
     return PackageBuild
         { pbVersion = version
-        , pbMaintainer = fmap snd $ lookup name $ pcPackages pc
+        , pbVersionRange = superSimplifyVersionRange
+                         $ maybe anyVersion fst $ lookup name $ pcPackages pc
+        , pbMaintainer = lookup name (pcPackages pc) >>= snd
         , pbGithubPings = getGithubPings gpd
         , pbUsers = mempty -- must be filled in later
         , pbFlags = flags

Stackage2/PackageConstraints.hs

@@ -39,18 +39,20 @@ instance FromJSON TestState where
                $ map (\x -> (testStateToText x, x)) [minBound..maxBound]
 
 data PackageConstraints = PackageConstraints
-    { pcPackages :: Map PackageName (VersionRange, Maintainer)
+    { pcPackages :: Map PackageName (VersionRange, Maybe Maintainer)
     -- ^ This does not include core packages or dependencies, just packages
     -- added by some maintainer.
     , pcGhcVersion :: Version
     , pcOS :: OS
     , pcArch :: Arch
-    , pcFlagOverrides :: PackageName -> Map FlagName Bool
+    , pcCorePackages :: Map PackageName Version
+    , pcCoreExecutables :: Set ExeName
+
+    -- Have a single lookup function with all of the package-specific stuff?
     , pcTests :: PackageName -> TestState
     , pcHaddocks :: PackageName -> TestState
     , pcBuildBenchmark :: PackageName -> Bool
-    , pcCorePackages :: Map PackageName Version
+    , pcFlagOverrides :: PackageName -> Map FlagName Bool
-    , pcCoreExecutables :: Set ExeName
     }
 
 -- | The proposed plan from the requirements provided by contributors.
@@ -78,7 +80,7 @@ defaultPackageConstraints = do
             old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings
 
     return PackageConstraints
-        { pcPackages = fmap (Maintainer . pack . Old.unMaintainer)
+        { pcPackages = fmap (Just . Maintainer . pack . Old.unMaintainer)
                    <$> Old.defaultStablePackages oldGhcVer False
         , pcCorePackages = core
         , pcCoreExecutables = coreExes

Stackage2/PackageDescription.hs

@@ -41,11 +41,11 @@ instance Monoid SimpleTree where
         (b ++ y)
         (c ++ z)
 
-data SimpleExtra = SimpleExtra
+data SimpleExtra = SimpleExtra -- FIXME fold into FlatComponent?
     { seTools :: Map ExeName VersionRange
     , seProvidedExes :: Set ExeName
     }
-    deriving Show
+    deriving (Show, Eq)
 instance Monoid SimpleExtra where
     mempty = SimpleExtra mempty mempty
     mappend (SimpleExtra a b) (SimpleExtra x y) = SimpleExtra
@@ -102,7 +102,7 @@ data FlatComponent = FlatComponent
     { fcDeps :: Map PackageName VersionRange
     , fcExtra :: SimpleExtra
     }
-    deriving Show
+    deriving (Show, Eq)
 instance Monoid FlatComponent where
     mempty = FlatComponent mempty mempty
     mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent

Stackage2/Prelude.hs

@@ -79,7 +79,7 @@ withCheckedProcess cp f = do
     return res
 
 newtype Maintainer = Maintainer { unMaintainer :: Text }
-    deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON)
+    deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)
 
 -- | Name of an executable.
 newtype ExeName = ExeName { unExeName :: Text }

Stackage2/UpdateBuildPlan.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+-- | Take an existing build plan and bump all packages to the newest version in
+-- the same major version number.
+module Stackage2.UpdateBuildPlan
+    ( updatePackageConstraints
+    , updateBuildPlan
+    ) where
+
+import Stackage2.Prelude
+import Stackage2.BuildPlan
+import Stackage2.PackageConstraints
+import Stackage2.PackageDescription
+import Distribution.Version (orLaterVersion, earlierVersion)
+
+updateBuildPlan :: BuildPlan a -> IO (BuildPlan FlatComponent)
+updateBuildPlan = newBuildPlan . updatePackageConstraints
+
+updatePackageConstraints :: BuildPlan a -> PackageConstraints
+updatePackageConstraints BuildPlan {..} = PackageConstraints
+    { pcPackages = flip map bpExtra $ \pb ->
+        ( intersectVersionRanges (bumpRange (pbVersion pb)) (pbVersionRange pb)
+        , pbMaintainer pb
+        )
+    , pcCorePackages = bpCore
+    , pcCoreExecutables = bpCoreExecutables
+    , pcGhcVersion = bpGhcVersion
+    , pcOS = bpOS
+    , pcArch = bpArch
+    , pcTests = maybe ExpectSuccess pbTestState . flip lookup bpExtra
+    , pcHaddocks = maybe ExpectSuccess pbHaddockState . flip lookup bpExtra
+    , pcBuildBenchmark = maybe True pbTryBuildBenchmark . flip lookup bpExtra
+    , pcFlagOverrides = maybe mempty pbFlags . flip lookup bpExtra
+    }
+  where
+    bumpRange version = intersectVersionRanges
+        (orLaterVersion version)
+        (earlierVersion $ bumpVersion version)
+    bumpVersion (Version (x:y:_) _) = Version [x, y + 1] []
+    bumpVersion (Version [x] _) = Version [x, 1] []
+    bumpVersion (Version [] _) = assert False $ Version [1, 0] []

stackage.cabal

@@ -37,6 +37,7 @@ library
                        Stackage2.PackageIndex
                        Stackage2.BuildPlan
                        Stackage2.CheckBuildPlan
+                       Stackage2.UpdateBuildPlan
                        Stackage2.GithubPings
                        Stackage2.PackageDescription
   build-depends:       base >= 4 && < 5
@@ -84,6 +85,7 @@ test-suite spec
                      , classy-prelude-conduit
                      , Cabal
                      , yaml
+                     , containers
 
 source-repository head
   type:     git

test/Stackage2/BuildPlanSpec.hs

@@ -4,13 +4,32 @@ module Stackage2.BuildPlanSpec (spec) where
 import Stackage2.BuildPlan
 import Stackage2.Prelude
 import Stackage2.PackageConstraints
+import Stackage2.UpdateBuildPlan
 import Test.Hspec
 import qualified Data.Yaml as Y
 import Control.Exception (evaluate)
+import Distribution.Version (anyVersion)
+import qualified Data.Map as Map
 
 spec :: Spec
 spec = it "works" $ do
-    bp <- defaultPackageConstraints >>= newBuildPlan
+    pc <- defaultPackageConstraints
+    bp <- newBuildPlan pc
     let bs = Y.encode bp
         mbp' = Y.decode bs
+
+    bp' <- maybe (error "decoding failed") return mbp'
+
+    let allPackages = Map.keysSet (bpExtra bp) ++ Map.keysSet (bpExtra bp')
+    forM_ allPackages $ \name ->
+        (name, lookup name (bpExtra bp')) `shouldBe`
+        (name, lookup name (bpExtra $ () <$ bp))
+
     mbp' `shouldBe` Just (() <$ bp)
+    bp2 <- newBuildPlan $ updatePackageConstraints bp
+    dropVersionRanges bp2 `shouldBe` dropVersionRanges bp
+  where
+    dropVersionRanges bp =
+        bp { bpExtra = map go $ bpExtra bp }
+      where
+        go pb = pb { pbVersionRange = anyVersion }