WIP changes with better naming

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

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
+    { bpSystemInfo :: SystemInfo
-    , bpCoreExecutables :: Set ExeName
-    , bpGhcVersion :: Version
-    , bpOS :: Distribution.System.OS
-    , bpArch :: Distribution.System.Arch
     , 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)
+        [ "system-info" .= bpSystemInfo
-        , "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
+        , "packages" .= Map.mapKeysWith const unPackageName bpPackages
         ]
       where
-        toCore (x, y) = (asText $ display x, asText $ display y)
+        goTool (k, v) = object
-        goTool (name, version) = object
+            [ "name" .= display k
-            [ "name" .= asText (display name)
+            , "version" .= display v
-            , "version" .= asText (display version)
             ]
 instance desc ~ () => FromJSON (BuildPlan desc) where
     parseJSON = withObject "BuildPlan" $ \o -> do
-        bpCore <- (o .: "core") >>= goCore
+        bpSystemInfo <- o .: "system-info"
-        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")
+        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
+    , pbPackageConstraints :: PackageConstraints
-    , pbTestState         :: TestState
-    , pbHaddockState      :: TestState
-    , pbTryBuildBenchmark :: Bool
     , 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
+    toJSON PackageBuild {..} = object
-        [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer
+        [ "version" .= asText (display pbVersion)
-        ,
+        , "github-pings" .= pbGithubPings
-            [ "version" .= asText (display pbVersion)
+        , "users" .= map unPackageName (unpack pbUsers)
-            , "version-range" .= asText (display $ superSimplifyVersionRange pbVersionRange)
+        , "constraints" .= pbPackageConstraints
-            , "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
-            ]
         ]
 instance desc ~ () => FromJSON (PackageBuild desc) where
-    parseJSON = withObject "PackageBuild" $ \o -> PackageBuild
+    parseJSON = withObject "PackageBuild" $ \o -> do
-        <$> (o .: "version" >>= efail . simpleParse . asText)
+        pbVersion <- o .: "version" >>= efail . simpleParse . asText
-        <*> (o .: "version-range" >>= fmap superSimplifyVersionRange . efail . simpleParse . asText)
+        pbGithubPings <- o .:? "github-pings" .!= mempty
-        <*> o .:? "maintainer"
+        pbUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)
-        <*> o .:? "github-pings" .!= mempty
+        pbPackageConstraints <- o .: "constraints"
-        <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))
+        return PackageBuild {..}
-        <*> (toFlags <$> (o .:? "flags" .!= mempty))
-        <*> o .: "test-state"
-        <*> o .: "haddock-state"
-        <*> o .: "build-benchmark"
-        <*> pure ()
       where
-        toFlags = Map.mapKeysWith const (FlagName . unpack . asText)
+        pbDesc = ()
-
         efail = either (fail . show) return
 
-newBuildPlan :: MonadIO m => PackageConstraints -> m (BuildPlan FlatComponent)
+newBuildPlan :: MonadIO m => BuildConstraints -> m (BuildPlan FlatComponent)
-newBuildPlan pc = liftIO $ do
+newBuildPlan bc@BuildConstraints {..} = liftIO $ do
-    extraOrig <- getLatestDescriptions (isAllowed pc) (mkPackageBuild pc)
+    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
+        { bpSystemInfo = bcSystemInfo
-        , bpCoreExecutables = pcCoreExecutables pc
-        , bpGhcVersion = pcGhcVersion pc
-        , bpOS = pcOS pc
-        , bpArch = pcArch pc
         , 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 $
+    included = flip execState mempty $ mapM_ add bcPackages
-        mapM_ (add . fst) $ mapToList $ pcPackages pc
 
     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 ->
+isAllowed bc = \name version ->
-    case lookup name $ pcCorePackages pc of
+    case lookup name $ siCorePackages $ bcSystemInfo bc of
         Just _ -> False -- never reinstall a core package
-        Nothing ->
+        Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name
-            case lookup name $ pcPackages pc of
-                Nothing -> True -- no constraints
-                Just (range, _) -> withinRange version range
 
 mkPackageBuild :: MonadThrow m
-               => PackageConstraints
+               => BuildConstraints
                -> GenericPackageDescription
                -> m (PackageBuild FlatComponent)
-mkPackageBuild pc gpd = do
+mkPackageBuild bc gpd = do
-    let overrides = pcFlagOverrides pc name
+    pbDesc <- getFlattenedComponent CheckCond {..} gpd
-        getFlag MkFlag {..} =
+    return PackageBuild {..}
-            (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
-        }
   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

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 ++ ".")
+    $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
-    : map (("@" ++) . unpack) (setToList puGithubPings)
+    : 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

Stackage2/PackageConstraints.hs

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

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
     }

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)
+simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m 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

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
+updateBuildConstraints :: BuildPlan a -> BuildConstraints
-updatePackageConstraints BuildPlan {..} = PackageConstraints
+updateBuildConstraints BuildPlan {..} =
-    { pcPackages = flip map bpExtra $ \pb ->
+    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
+    pcTests = maybe ExpectSuccess pbTestState . flip lookup bpExtra
-    , pcCoreExecutables = bpCoreExecutables
+    pcHaddocks = maybe ExpectSuccess pbHaddockState . flip lookup bpExtra
-    , pcGhcVersion = bpGhcVersion
+    pcBuildBenchmark = maybe True pbTryBuildBenchmark . flip lookup bpExtra
-    , pcOS = bpOS
+    pcFlagOverrides = maybe mempty pbFlags . flip lookup bpExtra
-    , 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)

stackage.cabal

@@ -32,7 +32,7 @@ library
                        Stackage.ServerFiles
 
                        Stackage2.Prelude
-                       Stackage2.PackageConstraints
+                       Stackage2.BuildConstraints
                        Stackage2.CorePackages
                        Stackage2.PackageIndex
                        Stackage2.BuildPlan

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
+    bc <- defaultBuildConstraints
-    bp <- newBuildPlan pc
+    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 (bpPackages bp')) `shouldBe`
-        (name, lookup name (bpExtra $ () <$ bp))
+        (name, lookup name (bpPackages (() <$ bp)))
 
-    mbp' `shouldBe` Just (() <$ bp)
+    bp' `shouldBe` (() <$ bp)
-    bp2 <- newBuildPlan $ updatePackageConstraints 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 }