diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs index 50a85ab5..f1b4a32e 100644 --- a/Stackage2/BuildPlan.hs +++ b/Stackage2/BuildPlan.hs @@ -18,7 +18,6 @@ module Stackage2.BuildPlan import Distribution.Package (Dependency (..)) import Distribution.PackageDescription import Distribution.Version (withinRange, intersectVersionRanges) -import Stackage2.CorePackages import Stackage2.PackageConstraints import Stackage2.PackageIndex import Stackage2.Prelude @@ -122,44 +121,23 @@ instance desc ~ () => FromJSON (PackageBuild desc) where efail = either (fail . show) return -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] - -newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent) -newBuildPlan = liftIO $ do - core <- getCorePackages - coreExes <- getCoreExecutables - extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild +newBuildPlan :: MonadIO m => PackageConstraints -> m (BuildPlan FlatComponent) +newBuildPlan pc = liftIO $ do + extraOrig <- getLatestDescriptions (isAllowed pc) (mkPackageBuild pc) let toolMap = makeToolMap extraOrig - extra = populateUsers $ removeUnincluded toolMap coreExes extraOrig + extra = populateUsers $ removeUnincluded pc toolMap extraOrig toolNames :: [ExeName] toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra tools <- topologicalSortTools toolMap $ mapFromList $ do exeName <- toolNames - guard $ exeName `notMember` coreExes + guard $ exeName `notMember` pcCoreExecutables pc 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 = core + { bpCore = pcCorePackages pc + -- bpCoreExes = pcCoreExecutables pc , bpTools = tools , bpExtra = extra } @@ -206,16 +184,18 @@ data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) deriving (Show, Typeable) instance (Show key, Typeable key) => Exception (TopologicalSortException key) -removeUnincluded :: Map ExeName (Set PackageName) - -> Set ExeName -- ^ core exes +removeUnincluded :: PackageConstraints + -> Map ExeName (Set PackageName) -> Map PackageName (PackageBuild FlatComponent) -> Map PackageName (PackageBuild FlatComponent) -removeUnincluded toolMap coreExes orig = +removeUnincluded pc toolMap orig = mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig where + coreExes = pcCoreExecutables pc + included :: Set PackageName included = flip execState mempty $ - mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints + mapM_ (add . fst) $ mapToList $ pcPackages pc add name = do inc <- get @@ -240,56 +220,46 @@ populateUsers orig = | dep `member` fcDeps (pbDesc pb) = singletonSet user | otherwise = mempty -isAllowed :: Map PackageName Version -- ^ core +isAllowed :: PackageConstraints -> PackageName -> Version -> Bool -isAllowed core = \name version -> - case lookup name core of +isAllowed pc = \name version -> + case lookup name $ pcCorePackages pc of Just _ -> False -- never reinstall a core package Nothing -> - case lookup name $ pcPackages defaultPackageConstraints of + case lookup name $ pcPackages pc of Nothing -> True -- no constraints Just (range, _) -> withinRange version range mkPackageBuild :: MonadThrow m - => GenericPackageDescription + => PackageConstraints + -> GenericPackageDescription -> m (PackageBuild FlatComponent) -mkPackageBuild gpd = do - let overrides = packageFlags name ++ defaultGlobalFlags +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 = Distribution.System.Linux - , ccArch = Distribution.System.X86_64 + , ccOS = pcOS pc + , ccArch = pcArch pc , ccCompilerFlavor = Distribution.Compiler.GHC - , ccCompilerVersion = ghcVerCabal + , ccCompilerVersion = pcGhcVersion pc , ccFlags = flags } - (tryBuildTest name) - (tryBuildBenchmark name) + (pcTests pc name /= Don'tBuild) + (pcBuildBenchmark pc name) gpd return PackageBuild { pbVersion = version - , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints + , pbMaintainer = fmap snd $ lookup name $ pcPackages pc , pbGithubPings = getGithubPings gpd , pbUsers = mempty -- must be filled in later , pbFlags = flags - , pbTestState = - case () of - () - | not $ tryBuildTest name -> Don'tBuild - | name `member` pcExpectedFailures defaultPackageConstraints - -> ExpectFailure - | otherwise -> ExpectSuccess - , pbHaddockState = - case () of - () - | name `member` pcExpectedFailures defaultPackageConstraints - -> ExpectFailure - | otherwise -> ExpectSuccess - , pbTryBuildBenchmark = tryBuildBenchmark name + , pbTestState = pcTests pc name + , pbHaddockState = pcHaddocks pc name + , pbTryBuildBenchmark = pcBuildBenchmark pc name , pbDesc = desc } where diff --git a/Stackage2/CorePackages.hs b/Stackage2/CorePackages.hs index c70b210b..8097ce8b 100644 --- a/Stackage2/CorePackages.hs +++ b/Stackage2/CorePackages.hs @@ -3,6 +3,7 @@ module Stackage2.CorePackages ( getCorePackages , getCoreExecutables + , getGhcVersion ) where import qualified Data.Text as T @@ -44,3 +45,9 @@ getCoreExecutables = do Nothing -> error "No ghc executable found on PATH" Just fp -> return $ directory $ fpFromString fp (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir + +getGhcVersion :: IO Version +getGhcVersion = do + withCheckedProcess (proc "ghc" ["--numeric-version"]) $ + \ClosedStream src Inherited -> + (src $$ decodeUtf8C =$ foldC) >>= simpleParse diff --git a/Stackage2/PackageConstraints.hs b/Stackage2/PackageConstraints.hs index 63850143..72594e1a 100644 --- a/Stackage2/PackageConstraints.hs +++ b/Stackage2/PackageConstraints.hs @@ -4,75 +4,115 @@ -- | The constraints on package selection for a new build plan. module Stackage2.PackageConstraints ( PackageConstraints (..) + , TestState (..) , defaultPackageConstraints - , defaultGlobalFlags - , packageFlags - , tryBuildTest - , tryBuildBenchmark - , ghcVerCabal ) 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 --- FIXME have the defaults here live in IO to make sure we don't have any --- global state floating around. Will make it easier to test. +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, Maintainer) -- ^ This does not include core packages or dependencies, just packages -- added by some maintainer. - , pcExpectedFailures :: Set PackageName - -- ^ At some point in the future, we should split this into Haddock - -- failures, test failures, etc. + , pcGhcVersion :: Version + , pcOS :: OS + , pcArch :: Arch + , pcFlagOverrides :: PackageName -> Map FlagName Bool + , pcTests :: PackageName -> TestState + , pcHaddocks :: PackageName -> TestState + , pcBuildBenchmark :: PackageName -> Bool + , pcCorePackages :: Map PackageName Version + , pcCoreExecutables :: Set ExeName } -- | The proposed plan from the requirements provided by contributors. -defaultPackageConstraints :: PackageConstraints -defaultPackageConstraints = PackageConstraints - { pcPackages = fmap (Maintainer . pack . Old.unMaintainer) - <$> Old.defaultStablePackages ghcVer False - , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False - } +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 --- FIXME below here shouldn't be so hard-coded -ghcVer :: Old.GhcMajorVersion -ghcVer = Old.GhcMajorVersion 7 8 + 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 -ghcVerCabal :: Version -ghcVerCabal = Version [7, 8, 3] [] - -oldSettings :: Old.SelectSettings -oldSettings = Old.defaultSelectSettings ghcVer False - -defaultGlobalFlags :: Map FlagName Bool -defaultGlobalFlags = mapFromList $ - map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++ - map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings) + return PackageConstraints + { pcPackages = fmap (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 -tryBuildTest :: PackageName -> Bool -tryBuildTest (PackageName name) = pack name `notMember` skippedTests - -tryBuildBenchmark :: PackageName -> Bool -tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs - -skippedTests :: HashSet Text -skippedTests = (old ++ ) $ setFromList $ words =<< +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 ] - where - old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings skippedBenchs :: HashSet Text skippedBenchs = setFromList $ words =<< diff --git a/Stackage2/PackageDescription.hs b/Stackage2/PackageDescription.hs index 736bc4db..2e398af1 100644 --- a/Stackage2/PackageDescription.hs +++ b/Stackage2/PackageDescription.hs @@ -18,7 +18,6 @@ module Stackage2.PackageDescription import Distribution.Package (Dependency (..)) import Distribution.PackageDescription import Stackage2.CorePackages -import Stackage2.PackageConstraints import Stackage2.PackageIndex import Stackage2.Prelude import Stackage2.GithubPings diff --git a/test/Stackage2/BuildPlanSpec.hs b/test/Stackage2/BuildPlanSpec.hs index b4b42aac..57e86361 100644 --- a/test/Stackage2/BuildPlanSpec.hs +++ b/test/Stackage2/BuildPlanSpec.hs @@ -3,14 +3,14 @@ module Stackage2.BuildPlanSpec (spec) where import Stackage2.BuildPlan import Stackage2.Prelude +import Stackage2.PackageConstraints import Test.Hspec import qualified Data.Yaml as Y import Control.Exception (evaluate) spec :: Spec spec = it "works" $ do - bp <- newBuildPlan + bp <- defaultPackageConstraints >>= newBuildPlan let bs = Y.encode bp mbp' = Y.decode bs - Y.encodeFile "myplan.yaml" bp mbp' `shouldBe` Just (() <$ bp)