diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs index f1b4a32e..a088d75c 100644 --- a/Stackage2/BuildPlan.hs +++ b/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 - <$> ((o .: "core") >>= goCore) - <*> ((o .: "tools") >>= mapM goTool) - <*> (goExtra <$> (o .: "extra")) + parseJSON = withObject "BuildPlan" $ \o -> do + bpCore <- (o .: "core") >>= goCore + bpCoreExecutables <- o .: "core-exes" + 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 diff --git a/Stackage2/PackageConstraints.hs b/Stackage2/PackageConstraints.hs index 72594e1a..a3c92b5a 100644 --- a/Stackage2/PackageConstraints.hs +++ b/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 - , pcCoreExecutables :: Set ExeName + , pcFlagOverrides :: PackageName -> Map FlagName Bool } -- | 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 diff --git a/Stackage2/PackageDescription.hs b/Stackage2/PackageDescription.hs index 2e398af1..3aff369b 100644 --- a/Stackage2/PackageDescription.hs +++ b/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 diff --git a/Stackage2/Prelude.hs b/Stackage2/Prelude.hs index a9324ec1..26004c51 100644 --- a/Stackage2/Prelude.hs +++ b/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 } diff --git a/Stackage2/UpdateBuildPlan.hs b/Stackage2/UpdateBuildPlan.hs new file mode 100644 index 00000000..f87cd330 --- /dev/null +++ b/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] [] diff --git a/stackage.cabal b/stackage.cabal index e76c8243..cb643d09 100644 --- a/stackage.cabal +++ b/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 diff --git a/test/Stackage2/BuildPlanSpec.hs b/test/Stackage2/BuildPlanSpec.hs index 57e86361..945e1b34 100644 --- a/test/Stackage2/BuildPlanSpec.hs +++ b/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 }