Less global state

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

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

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 =<<

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

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)