From 85597597bbc8a07315931ff095f4bac9e5e9cfd8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 8 Dec 2014 11:27:46 +0200 Subject: [PATCH] WIP changes with better naming --- Stackage2/BuildConstraints.hs | 186 +++++++++++++++++++++++++++++ Stackage2/BuildPlan.hs | 199 +++++++++++--------------------- Stackage2/CheckBuildPlan.hs | 21 ++-- Stackage2/PackageConstraints.hs | 123 -------------------- Stackage2/PackageDescription.hs | 11 +- Stackage2/Prelude.hs | 20 +++- Stackage2/UpdateBuildPlan.hs | 39 ++++--- stackage.cabal | 2 +- test/Stackage2/BuildPlanSpec.hs | 25 ++-- 9 files changed, 326 insertions(+), 300 deletions(-) create mode 100644 Stackage2/BuildConstraints.hs delete mode 100644 Stackage2/PackageConstraints.hs diff --git a/Stackage2/BuildConstraints.hs b/Stackage2/BuildConstraints.hs new file mode 100644 index 00000000..82ce4d15 --- /dev/null +++ b/Stackage2/BuildConstraints.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +-- | The constraints on package selection for a new build plan. +module Stackage2.BuildConstraints + ( BuildConstraints (..) + , PackageConstraints (..) + , TestState (..) + , SystemInfo (..) + , defaultBuildConstraints + ) where + +import Stackage2.Prelude +import Stackage2.CorePackages +import qualified Stackage.Config as Old +import qualified Stackage.Types as Old +import qualified Stackage.Select as Old +import Data.Aeson +import Distribution.System (OS, Arch) +import Distribution.Version (anyVersion) +import qualified Distribution.System +import qualified Data.Map as Map + +data TestState = ExpectSuccess + | ExpectFailure + | Don'tBuild -- ^ when the test suite will pull in things we don't want + deriving (Show, Eq, Ord, Bounded, Enum) + +testStateToText :: TestState -> Text +testStateToText ExpectSuccess = "expect-success" +testStateToText ExpectFailure = "expect-failure" +testStateToText Don'tBuild = "do-not-build" + +instance ToJSON TestState where + toJSON = toJSON . testStateToText +instance FromJSON TestState where + parseJSON = withText "TestState" $ \t -> + case lookup t states of + Nothing -> fail $ "Invalid state: " ++ unpack t + Just v -> return v + where + states = asHashMap $ mapFromList + $ map (\x -> (testStateToText x, x)) [minBound..maxBound] + +data SystemInfo = SystemInfo + { siGhcVersion :: Version + , siOS :: OS + , siArch :: Arch + , siCorePackages :: Map PackageName Version + , siCoreExecutables :: Set ExeName + } + deriving (Show, Eq, Ord) +instance ToJSON SystemInfo where + toJSON SystemInfo {..} = object + [ "ghc-version" .= display siGhcVersion + , "os" .= display siOS + , "arch" .= display siArch + , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages) + , "core-executables" .= siCoreExecutables + ] +instance FromJSON SystemInfo where + parseJSON = withObject "SystemInfo" $ \o -> do + let helper name = (o .: name) >>= either (fail . show) return . simpleParse + siGhcVersion <- helper "ghc-version" + siOS <- helper "os" + siArch <- helper "arch" + siCorePackages <- (o .: "core-packages") >>= goPackages + siCoreExecutables <- o .: "core-executables" + return SystemInfo {..} + where + goPackages = either (fail . show) return + . mapM simpleParse + . Map.mapKeysWith const mkPackageName + +data BuildConstraints = BuildConstraints + { bcPackages :: Set PackageName + -- ^ This does not include core packages. + , bcPackageConstraints :: PackageName -> PackageConstraints + + , bcSystemInfo :: SystemInfo + } + +data PackageConstraints = PackageConstraints + { pcVersionRange :: VersionRange + , pcMaintainer :: Maybe Maintainer + , pcTests :: TestState + , pcHaddocks :: TestState + , pcBuildBenchmarks :: Bool + , pcFlagOverrides :: Map FlagName Bool + } + deriving (Show, Eq) +instance ToJSON PackageConstraints where + toJSON PackageConstraints {..} = object $ addMaintainer + [ "version-range" .= display pcVersionRange + , "tests" .= pcTests + , "haddocks" .= pcHaddocks + , "build-benchmarks" .= pcBuildBenchmarks + , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides + ] + where + addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer +instance FromJSON PackageConstraints where + parseJSON = withObject "PackageConstraints" $ \o -> do + pcVersionRange <- (o .: "version-range") + >>= either (fail . show) return . simpleParse + pcTests <- o .: "tests" + pcHaddocks <- o .: "haddocks" + pcBuildBenchmarks <- o .: "build-benchmarks" + pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags" + pcMaintainer <- o .:? "maintainer" + return PackageConstraints {..} + +-- | The proposed plan from the requirements provided by contributors. +defaultBuildConstraints :: IO BuildConstraints +defaultBuildConstraints = do + siCorePackages <- getCorePackages + siCoreExecutables <- getCoreExecutables + siGhcVersion <- getGhcVersion + oldGhcVer <- + case siGhcVersion of + Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y + _ -> error $ "Didn't not understand GHC version: " ++ show siGhcVersion + + + let oldSettings = Old.defaultSelectSettings oldGhcVer False + oldStable = Old.defaultStablePackages oldGhcVer False + defaultGlobalFlags = asMap $ mapFromList $ + map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++ + map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings) + tryBuildTest (PackageName name) = pack name `notMember` skippedTests + tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs + expectedFailures = Old.defaultExpectedFailures oldGhcVer False + skippedTests = + old ++ extraSkippedTests + where + old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings + + bcPackages = Map.keysSet oldStable + bcPackageConstraints name = + PackageConstraints {..} + where + mold = lookup name $ oldStable + + pcVersionRange = simplifyVersionRange $ maybe anyVersion fst mold + pcMaintainer = (Maintainer . pack . Old.unMaintainer . snd) <$> mold + pcTests + | not $ tryBuildTest name = Don'tBuild + | name `member` expectedFailures = ExpectFailure + | otherwise = ExpectSuccess + + pcBuildBenchmarks = unPackageName name `notMember` skippedBenchs + + -- FIXME ultimately separate haddock and test failures in specification + pcHaddocks + | name `member` expectedFailures = ExpectFailure + | otherwise = ExpectSuccess + + pcFlagOverrides = packageFlags name ++ defaultGlobalFlags + + -- FIXME consider not hard-coding the next two values + siOS = Distribution.System.Linux + siArch = Distribution.System.X86_64 + + bcSystemInfo = SystemInfo {..} + + return BuildConstraints {..} + +packageFlags :: PackageName -> Map FlagName Bool +packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False +packageFlags _ = mempty + +extraSkippedTests :: HashSet Text +extraSkippedTests = setFromList $ words =<< + [ "HTTP Octree options" + , "hasql" + , "bloodhound fb" -- require old hspec + , "diagrams-haddock" -- requires old tasty + , "hasql-postgres" -- requires old hasql + ] + +skippedBenchs :: HashSet Text +skippedBenchs = setFromList $ words =<< + [ "machines criterion-plus graphviz lifted-base pandoc stm-containers uuid" + , "cases hasql-postgres" -- pulls in criterion-plus, which has restrictive upper bounds + ] diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs index a088d75c..dcfb9d33 100644 --- a/Stackage2/BuildPlan.hs +++ b/Stackage2/BuildPlan.hs @@ -18,7 +18,7 @@ module Stackage2.BuildPlan import Distribution.Package (Dependency (..)) import Distribution.PackageDescription import Distribution.Version (withinRange, anyVersion, simplifyVersionRange) -import Stackage2.PackageConstraints +import Stackage2.BuildConstraints import Stackage2.PackageIndex import Stackage2.Prelude import Stackage2.GithubPings @@ -31,13 +31,9 @@ import qualified Distribution.System 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 + { bpSystemInfo :: SystemInfo , bpTools :: Vector (PackageName, Version) - , bpExtra :: Map PackageName (PackageBuild desc) + , bpPackages :: Map PackageName (PackageBuild desc) } deriving (Functor, Foldable, Traversable, Show, Eq) type instance Element (BuildPlan desc) = desc @@ -47,58 +43,33 @@ 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) + [ "system-info" .= bpSystemInfo , "tools" .= map goTool bpTools - , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra + , "packages" .= Map.mapKeysWith const unPackageName bpPackages ] where - toCore (x, y) = (asText $ display x, asText $ display y) - goTool (name, version) = object - [ "name" .= asText (display name) - , "version" .= asText (display version) + goTool (k, v) = object + [ "name" .= display k + , "version" .= display v ] instance desc ~ () => FromJSON (BuildPlan desc) where 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 + bpSystemInfo <- o .: "system-info" bpTools <- (o .: "tools") >>= mapM goTool - bpExtra <- goExtra <$> (o .: "extra") + bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") return BuildPlan {..} where - goCore = - fmap mapFromList . mapM goCore' . mapToList . asHashMap - where - goCore' (k, v) = do - k' <- either (fail . show) return $ simpleParse $ asText k - v' <- either (fail . show) return $ simpleParse $ asText v - return (k', v') - goTool = withObject "Tool" $ \o -> (,) <$> ((o .: "name") >>= either (fail . show) return . simpleParse . asText) <*> ((o .: "version") >>= either (fail . show) return . simpleParse . asText) - goExtra = Map.mapKeysWith const PackageName - 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 - , pbFlags :: Map FlagName Bool - , pbTestState :: TestState - , pbHaddockState :: TestState - , pbTryBuildBenchmark :: Bool + , pbPackageConstraints :: PackageConstraints , pbDesc :: desc } deriving (Functor, Foldable, Traversable, Show, Eq) @@ -107,69 +78,45 @@ 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 - , "test-state" .= pbTestState - , "haddock-state" .= pbHaddockState - , "build-benchmark" .= pbTryBuildBenchmark - ] + toJSON PackageBuild {..} = object + [ "version" .= asText (display pbVersion) + , "github-pings" .= pbGithubPings + , "users" .= map unPackageName (unpack pbUsers) + , "constraints" .= pbPackageConstraints ] 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)) - <*> (toFlags <$> (o .:? "flags" .!= mempty)) - <*> o .: "test-state" - <*> o .: "haddock-state" - <*> o .: "build-benchmark" - <*> pure () + parseJSON = withObject "PackageBuild" $ \o -> do + pbVersion <- o .: "version" >>= efail . simpleParse . asText + pbGithubPings <- o .:? "github-pings" .!= mempty + pbUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) + pbPackageConstraints <- o .: "constraints" + return PackageBuild {..} where - toFlags = Map.mapKeysWith const (FlagName . unpack . asText) - + pbDesc = () efail = either (fail . show) return -newBuildPlan :: MonadIO m => PackageConstraints -> m (BuildPlan FlatComponent) -newBuildPlan pc = liftIO $ do - extraOrig <- getLatestDescriptions (isAllowed pc) (mkPackageBuild pc) +newBuildPlan :: MonadIO m => BuildConstraints -> m (BuildPlan FlatComponent) +newBuildPlan bc@BuildConstraints {..} = liftIO $ do + extraOrig <- getLatestDescriptions (isAllowed bc) (mkPackageBuild bc) let toolMap = makeToolMap extraOrig - extra = populateUsers $ removeUnincluded pc toolMap extraOrig + extra = populateUsers $ removeUnincluded bc toolMap extraOrig toolNames :: [ExeName] toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra tools <- topologicalSortTools toolMap $ mapFromList $ do exeName <- toolNames - guard $ exeName `notMember` pcCoreExecutables pc + guard $ exeName `notMember` siCoreExecutables packageName <- maybe mempty setToList $ lookup exeName toolMap packageBuild <- maybeToList $ lookup packageName extraOrig return (packageName, packageBuild) -- FIXME topologically sort packages? maybe just leave that to the build phase return BuildPlan - { bpCore = pcCorePackages pc - , bpCoreExecutables = pcCoreExecutables pc - , bpGhcVersion = pcGhcVersion pc - , bpOS = pcOS pc - , bpArch = pcArch pc + { bpSystemInfo = bcSystemInfo , bpTools = tools - , bpExtra = extra + , bpPackages = extra } + where + SystemInfo {..} = bcSystemInfo makeToolMap :: Map PackageName (PackageBuild FlatComponent) -> Map ExeName (Set PackageName) @@ -213,18 +160,19 @@ data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) deriving (Show, Typeable) instance (Show key, Typeable key) => Exception (TopologicalSortException key) -removeUnincluded :: PackageConstraints +-- | Include only packages which are dependencies of the required packages and +-- their build tools. +removeUnincluded :: BuildConstraints -> Map ExeName (Set PackageName) -> Map PackageName (PackageBuild FlatComponent) -> Map PackageName (PackageBuild FlatComponent) -removeUnincluded pc toolMap orig = +removeUnincluded BuildConstraints {..} toolMap orig = mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig where - coreExes = pcCoreExecutables pc + SystemInfo {..} = bcSystemInfo included :: Set PackageName - included = flip execState mempty $ - mapM_ (add . fst) $ mapToList $ pcPackages pc + included = flip execState mempty $ mapM_ add bcPackages add name = do inc <- get @@ -235,7 +183,7 @@ removeUnincluded pc toolMap orig = Just pb -> do mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $ - \exeName -> when (exeName `notMember` coreExes) + \exeName -> when (exeName `notMember` siCoreExecutables) $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap populateUsers :: Map PackageName (PackageBuild FlatComponent) @@ -249,49 +197,40 @@ populateUsers orig = | dep `member` fcDeps (pbDesc pb) = singletonSet user | otherwise = mempty -isAllowed :: PackageConstraints +-- | Check whether the given package/version combo meets the constraints +-- currently in place. +isAllowed :: BuildConstraints -> PackageName -> Version -> Bool -isAllowed pc = \name version -> - case lookup name $ pcCorePackages pc of +isAllowed bc = \name version -> + case lookup name $ siCorePackages $ bcSystemInfo bc of Just _ -> False -- never reinstall a core package - Nothing -> - case lookup name $ pcPackages pc of - Nothing -> True -- no constraints - Just (range, _) -> withinRange version range + Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name mkPackageBuild :: MonadThrow m - => PackageConstraints + => BuildConstraints -> GenericPackageDescription -> m (PackageBuild FlatComponent) -mkPackageBuild pc gpd = do - let overrides = pcFlagOverrides pc name - getFlag MkFlag {..} = - (flagName, fromMaybe flagDefault $ lookup flagName overrides) - flags = mapFromList $ map getFlag $ genPackageFlags gpd - desc <- getFlattenedComponent - CheckCond - { ccPackageName = name - , ccOS = pcOS pc - , ccArch = pcArch pc - , ccCompilerFlavor = Distribution.Compiler.GHC - , ccCompilerVersion = pcGhcVersion pc - , ccFlags = flags - } - (pcTests pc name /= Don'tBuild) - (pcBuildBenchmark pc name) - gpd - return PackageBuild - { pbVersion = version - , 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 - , pbTestState = pcTests pc name - , pbHaddockState = pcHaddocks pc name - , pbTryBuildBenchmark = pcBuildBenchmark pc name - , pbDesc = desc - } +mkPackageBuild bc gpd = do + pbDesc <- getFlattenedComponent CheckCond {..} gpd + return PackageBuild {..} where - PackageIdentifier name version = package $ packageDescription gpd + PackageIdentifier name pbVersion = package $ packageDescription gpd + pbGithubPings = getGithubPings gpd + pbPackageConstraints = bcPackageConstraints bc name + pbUsers = mempty -- must be filled in later + + ccPackageName = name + ccOS = siOS + ccArch = siArch + ccCompilerFlavor = Distribution.Compiler.GHC + ccCompilerVersion = siGhcVersion + ccFlags = flags + ccIncludeTests = pcTests pbPackageConstraints /= Don'tBuild + ccIncludeBenchmarks = pcBuildBenchmarks pbPackageConstraints + + SystemInfo {..} = bcSystemInfo bc + + overrides = pcFlagOverrides pbPackageConstraints + getFlag MkFlag {..} = + (flagName, fromMaybe flagDefault $ lookup flagName overrides) + flags = mapFromList $ map getFlag $ genPackageFlags gpd diff --git a/Stackage2/CheckBuildPlan.hs b/Stackage2/CheckBuildPlan.hs index 332ea680..b27f6af5 100644 --- a/Stackage2/CheckBuildPlan.hs +++ b/Stackage2/CheckBuildPlan.hs @@ -10,6 +10,7 @@ module Stackage2.CheckBuildPlan import Stackage2.Prelude import Stackage2.BuildPlan +import Stackage2.BuildConstraints import Stackage2.PackageDescription import Control.Monad.Writer.Strict (execWriter, Writer, tell) @@ -18,9 +19,9 @@ checkBuildPlan BuildPlan {..} | null errs' = return () | otherwise = throwM errs where - allPackages = bpCore ++ map pbVersion bpExtra + allPackages = siCorePackages bpSystemInfo ++ map pbVersion bpPackages errs@(BadBuildPlan errs') = - execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpExtra + execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages checkDeps :: Map PackageName Version -> (PackageName, PackageBuild FlatComponent) @@ -41,7 +42,7 @@ checkDeps allPackages (user, pb) = pu = PkgUser { puName = user , puVersion = pbVersion pb - , puMaintainer = pbMaintainer pb + , puMaintainer = pcMaintainer $ pbPackageConstraints pb , puGithubPings = pbGithubPings pb } @@ -53,17 +54,17 @@ data PkgUser = PkgUser } deriving (Eq, Ord) -pkgUserShow1 :: PkgUser -> String +pkgUserShow1 :: PkgUser -> Text pkgUserShow1 PkgUser {..} = concat [ display puName , "-" , display puVersion ] -pkgUserShow2 :: PkgUser -> String +pkgUserShow2 :: PkgUser -> Text pkgUserShow2 PkgUser {..} = unwords - $ (maybe "No maintainer" (unpack . unMaintainer) puMaintainer ++ ".") - : map (("@" ++) . unpack) (setToList puGithubPings) + $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".") + : map (cons '@') (setToList puGithubPings) newtype BadBuildPlan = BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange)) @@ -71,13 +72,13 @@ newtype BadBuildPlan = instance Exception BadBuildPlan instance Show BadBuildPlan where show (BadBuildPlan errs) = - concatMap go $ mapToList errs + unpack $ concatMap go $ mapToList errs where go ((dep, mdepVer), users) = unlines $ showDepVer dep mdepVer : map showUser (mapToList users) - showDepVer :: PackageName -> Maybe Version -> String + showDepVer :: PackageName -> Maybe Version -> Text showDepVer dep Nothing = display dep ++ " (not present) depended on by:" showDepVer dep (Just version) = concat [ display dep @@ -86,7 +87,7 @@ instance Show BadBuildPlan where , " depended on by:" ] - showUser :: (PkgUser, VersionRange) -> String + showUser :: (PkgUser, VersionRange) -> Text showUser (pu, range) = concat [ "- " , pkgUserShow1 pu diff --git a/Stackage2/PackageConstraints.hs b/Stackage2/PackageConstraints.hs deleted file mode 100644 index a3c92b5a..00000000 --- a/Stackage2/PackageConstraints.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} --- | The constraints on package selection for a new build plan. -module Stackage2.PackageConstraints - ( PackageConstraints (..) - , TestState (..) - , defaultPackageConstraints - ) where - -import Stackage2.Prelude -import Stackage2.CorePackages -import qualified Stackage.Config as Old -import qualified Stackage.Types as Old -import qualified Stackage.Select as Old -import Data.Aeson (ToJSON (..), FromJSON (..), withText) -import Distribution.System (OS, Arch) -import qualified Distribution.System - -data TestState = ExpectSuccess - | ExpectFailure - | Don'tBuild -- ^ when the test suite will pull in things we don't want - deriving (Show, Eq, Ord, Bounded, Enum) - -testStateToText :: TestState -> Text -testStateToText ExpectSuccess = "expect-success" -testStateToText ExpectFailure = "expect-failure" -testStateToText Don'tBuild = "do-not-build" - -instance ToJSON TestState where - toJSON = toJSON . testStateToText -instance FromJSON TestState where - parseJSON = withText "TestState" $ \t -> - case lookup t states of - Nothing -> fail $ "Invalid state: " ++ unpack t - Just v -> return v - where - states = asHashMap $ mapFromList - $ map (\x -> (testStateToText x, x)) [minBound..maxBound] - -data PackageConstraints = PackageConstraints - { 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 - , 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 - , pcFlagOverrides :: PackageName -> Map FlagName Bool - } - --- | The proposed plan from the requirements provided by contributors. -defaultPackageConstraints :: IO PackageConstraints -defaultPackageConstraints = do - core <- getCorePackages - coreExes <- getCoreExecutables - ghcVer <- getGhcVersion - oldGhcVer <- - case ghcVer of - Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y - _ -> error $ "Didn't not understand GHC version: " ++ show ghcVer - - - let oldSettings = Old.defaultSelectSettings oldGhcVer False - defaultGlobalFlags = asMap $ mapFromList $ - map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++ - map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings) - tryBuildTest (PackageName name) = pack name `notMember` skippedTests - tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs - expectedFailures = Old.defaultExpectedFailures oldGhcVer False - skippedTests = - old ++ extraSkippedTests - where - old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings - - return PackageConstraints - { pcPackages = fmap (Just . Maintainer . pack . Old.unMaintainer) - <$> Old.defaultStablePackages oldGhcVer False - , pcCorePackages = core - , pcCoreExecutables = coreExes - , pcOS = Distribution.System.Linux -- FIXME don't hard-code? - , pcArch = Distribution.System.X86_64 - , pcGhcVersion = ghcVer - , pcTests = \name -> - case () of - () - | not $ tryBuildTest name -> Don'tBuild - | name `member` expectedFailures -> ExpectFailure - | otherwise -> ExpectSuccess - , pcBuildBenchmark = (`notMember` skippedBenchs) . unPackageName - , pcFlagOverrides = \name -> packageFlags name ++ defaultGlobalFlags - , pcHaddocks = \name -> - case () of - () - | name `member` expectedFailures - -> ExpectFailure - | otherwise -> ExpectSuccess - } - -packageFlags :: PackageName -> Map FlagName Bool -packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False -packageFlags _ = mempty - -extraSkippedTests :: HashSet Text -extraSkippedTests = setFromList $ words =<< - [ "HTTP Octree options" - , "hasql" - , "bloodhound fb" -- require old hspec - , "diagrams-haddock" -- requires old tasty - , "hasql-postgres" -- requires old hasql - ] - -skippedBenchs :: HashSet Text -skippedBenchs = setFromList $ words =<< - [ "machines criterion-plus graphviz lifted-base pandoc stm-containers uuid" - , "cases hasql-postgres" -- pulls in criterion-plus, which has restrictive upper bounds - ] diff --git a/Stackage2/PackageDescription.hs b/Stackage2/PackageDescription.hs index 3aff369b..d0f95198 100644 --- a/Stackage2/PackageDescription.hs +++ b/Stackage2/PackageDescription.hs @@ -55,14 +55,15 @@ instance Monoid SimpleExtra where getFlattenedComponent :: MonadThrow m => CheckCond - -> Bool -- ^ include test suites? - -> Bool -- ^ include benchmarks? -> GenericPackageDescription -> m FlatComponent -getFlattenedComponent checkCond' includeTests includeBench gpd = +getFlattenedComponent checkCond' gpd = liftM fold $ mapM (flattenComponent checkCond') - $ getSimpleTrees includeTests includeBench gpd + $ getSimpleTrees + (ccIncludeTests checkCond') + (ccIncludeBenchmarks checkCond') + gpd getSimpleTrees :: Bool -- ^ include test suites? -> Bool -- ^ include benchmarks? @@ -150,4 +151,6 @@ data CheckCond = CheckCond , ccFlags :: Map FlagName Bool , ccCompilerFlavor :: CompilerFlavor , ccCompilerVersion :: Version + , ccIncludeTests :: Bool + , ccIncludeBenchmarks :: Bool } diff --git a/Stackage2/Prelude.hs b/Stackage2/Prelude.hs index 26004c51..d41b6af7 100644 --- a/Stackage2/Prelude.hs +++ b/Stackage2/Prelude.hs @@ -24,14 +24,19 @@ import Distribution.Version as X (withinRange) unPackageName :: PackageName -> Text unPackageName (PackageName str) = pack str +unFlagName :: FlagName -> Text +unFlagName (FlagName str) = pack str + mkPackageName :: Text -> PackageName mkPackageName = PackageName . unpack -display :: (IsString text, Element text ~ Char, DT.Text a) => a -> text +mkFlagName :: Text -> FlagName +mkFlagName = FlagName . unpack + +display :: DT.Text a => a -> Text display = fromString . DT.display -simpleParse :: (MonadThrow m, DT.Text a, Typeable a, MonoFoldable text, Element text ~ Char) - => text -> m a +simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a simpleParse orig = withTypeRep $ \rep -> case DT.simpleParse str of Nothing -> throwM (ParseFailedException rep (pack str)) @@ -87,3 +92,12 @@ newtype ExeName = ExeName { unExeName :: Text } intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y + +-- | 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. +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr = + fromMaybe (assert False vr') $ simpleParse $ display vr' + where + vr' = C.simplifyVersionRange vr diff --git a/Stackage2/UpdateBuildPlan.hs b/Stackage2/UpdateBuildPlan.hs index f87cd330..03b36c7d 100644 --- a/Stackage2/UpdateBuildPlan.hs +++ b/Stackage2/UpdateBuildPlan.hs @@ -4,36 +4,41 @@ -- | Take an existing build plan and bump all packages to the newest version in -- the same major version number. module Stackage2.UpdateBuildPlan - ( updatePackageConstraints + ( updateBuildConstraints , updateBuildPlan ) where import Stackage2.Prelude import Stackage2.BuildPlan -import Stackage2.PackageConstraints +import Stackage2.BuildConstraints import Stackage2.PackageDescription import Distribution.Version (orLaterVersion, earlierVersion) +import qualified Data.Map as Map updateBuildPlan :: BuildPlan a -> IO (BuildPlan FlatComponent) -updateBuildPlan = newBuildPlan . updatePackageConstraints +updateBuildPlan = newBuildPlan . updateBuildConstraints -updatePackageConstraints :: BuildPlan a -> PackageConstraints -updatePackageConstraints BuildPlan {..} = PackageConstraints - { pcPackages = flip map bpExtra $ \pb -> +updateBuildConstraints :: BuildPlan a -> BuildConstraints +updateBuildConstraints BuildPlan {..} = + BuildConstraints {..} + where + bcSystemInfo = bpSystemInfo + bcPackages = Map.keysSet bpPackages + + bcPackageConstraints name = + PackageConstraints {..} + where + {- + 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 + 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 + -} + bumpRange version = intersectVersionRanges (orLaterVersion version) (earlierVersion $ bumpVersion version) diff --git a/stackage.cabal b/stackage.cabal index cb643d09..eada7406 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -32,7 +32,7 @@ library Stackage.ServerFiles Stackage2.Prelude - Stackage2.PackageConstraints + Stackage2.BuildConstraints Stackage2.CorePackages Stackage2.PackageIndex Stackage2.BuildPlan diff --git a/test/Stackage2/BuildPlanSpec.hs b/test/Stackage2/BuildPlanSpec.hs index 945e1b34..66443d26 100644 --- a/test/Stackage2/BuildPlanSpec.hs +++ b/test/Stackage2/BuildPlanSpec.hs @@ -3,7 +3,7 @@ module Stackage2.BuildPlanSpec (spec) where import Stackage2.BuildPlan import Stackage2.Prelude -import Stackage2.PackageConstraints +import Stackage2.BuildConstraints import Stackage2.UpdateBuildPlan import Test.Hspec import qualified Data.Yaml as Y @@ -13,23 +13,24 @@ import qualified Data.Map as Map spec :: Spec spec = it "works" $ do - pc <- defaultPackageConstraints - bp <- newBuildPlan pc + bc <- defaultBuildConstraints + bp <- newBuildPlan bc let bs = Y.encode bp - mbp' = Y.decode bs + ebp' = Y.decodeEither bs - bp' <- maybe (error "decoding failed") return mbp' + bp' <- either error return ebp' - let allPackages = Map.keysSet (bpExtra bp) ++ Map.keysSet (bpExtra bp') + let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp') forM_ allPackages $ \name -> - (name, lookup name (bpExtra bp')) `shouldBe` - (name, lookup name (bpExtra $ () <$ bp)) + (name, lookup name (bpPackages bp')) `shouldBe` + (name, lookup name (bpPackages (() <$ bp))) - mbp' `shouldBe` Just (() <$ bp) - bp2 <- newBuildPlan $ updatePackageConstraints bp + bp' `shouldBe` (() <$ bp) + bp2 <- updateBuildPlan bp dropVersionRanges bp2 `shouldBe` dropVersionRanges bp where dropVersionRanges bp = - bp { bpExtra = map go $ bpExtra bp } + bp { bpPackages = map go $ bpPackages bp } where - go pb = pb { pbVersionRange = anyVersion } + go pb = pb { pbPackageConstraints = go' $ pbPackageConstraints pb } + go' pc = pc { pcVersionRange = anyVersion }