mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-11 23:08:30 +01:00
124 lines
4.8 KiB
Haskell
124 lines
4.8 KiB
Haskell
{-# 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
|
|
]
|