Flexible tests for checkBuildPlan (#375)

@snoyberg Can you confirm that this simple test suite works for you?
I've set this up so that I can then add some cyclic dependencies and add
an occurs check for that, but figured I'd setup tests for some of the
existing invariants first.

Should be like:

    $ cabal test --ghc-options=-O0; cat dist/test/stackage-0.4.0-spec.log
    Building stackage-0.4.0...
    Preprocessing library stackage-0.4.0...
    In-place registering stackage-0.4.0...
    Preprocessing executable 'stackage' for stackage-0.4.0...
    Preprocessing test suite 'spec' for stackage-0.4.0...
    [3 of 4] Compiling Stackage.BuildPlanSpec ( test/Stackage/BuildPlanSpec.hs, dist/build/spec/spec-tmp/Stackage/BuildPlanSpec.o )
    Linking dist/build/spec/spec ...
    Running 1 test suites...
    Test suite spec: RUNNING...
    Test suite spec: PASS
    Test suite logged to: dist/test/stackage-0.4.0-spec.log
    1 of 1 test suites (1 of 1 test cases) passed.
    Test suite spec: RUNNING...

    Stackage.BuildPlan
      simple package set
      bad version range on depdendency fails
      nonexistent package fails to check
      default package set checks ok
    Stackage.CorePackages
      works
      contains known core packages
      getCoreExecutables includes known executables
    Stackage.PackageIndex
      works
      getLatestDescriptions gives reasonable results

    Finished in 14.3302 seconds
    9 examples, 0 failures
    Test suite spec: PASS
    Test suite logged to: dist/test/stackage-0.4.0-spec.log

Stackage/BuildConstraints.hs

@@ -10,6 +10,7 @@ module Stackage.BuildConstraints
     , SystemInfo (..)
     , getSystemInfo
     , defaultBuildConstraints
+    , toBC
     ) where
 
 import           Control.Monad.Writer.Strict (execWriter, tell)

Stackage/CheckBuildPlan.hs

@@ -7,6 +7,7 @@
 -- | Confirm that a build plan has a consistent set of dependencies.
 module Stackage.CheckBuildPlan
     ( checkBuildPlan
+    , BadBuildPlan
     ) where
 
 import           Control.Monad.Writer.Strict (Writer, execWriter, tell)

test/Stackage/BuildPlanSpec.hs

@@ -1,22 +1,56 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
 module Stackage.BuildPlanSpec (spec) where
 
-import Stackage.BuildPlan
-import Stackage.Prelude
-import Stackage.BuildConstraints
-import Stackage.UpdateBuildPlan
-import Test.Hspec
-import qualified Data.Yaml as Y
-import Distribution.Version (anyVersion)
 import qualified Data.Map as Map
-import Network.HTTP.Client (withManager)
+import qualified Data.Map.Strict as M
-import Network.HTTP.Client.TLS (tlsManagerSettings)
+import qualified Data.Set as S
+import           Data.Yaml
+import qualified Data.Yaml as Y
+import           Distribution.Version
+import           Network.HTTP.Client
+import           Network.HTTP.Client.TLS (tlsManagerSettings)
+import           Stackage.BuildConstraints
+import           Stackage.BuildPlan
+import           Stackage.CheckBuildPlan
+import           Stackage.PackageDescription
+import           Stackage.Prelude
+import           Stackage.UpdateBuildPlan
+import           Test.Hspec
 
 spec :: Spec
-spec = it "works" $ withManager tlsManagerSettings $ \man -> do
+spec = do
-    bc <- defaultBuildConstraints man
+    it "simple package set" $ check testBuildConstraints $ makePackageSet
-    pkgs <- getLatestAllowedPlans bc
+        [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])
-    bp <- newBuildPlan pkgs bc
+        ,("bar", [0, 0, 0], [])]
+    it "bad version range on depdendency fails" $ badBuildPlan $ makePackageSet
+        [("foo", [0, 0, 0], [("bar", thisV [1, 1, 0])])
+        ,("bar", [0, 0, 0], [])]
+    it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet
+        [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])])
+        ,("bar", [0, 0, 0], [])]
+    it "default package set checks ok" $ check defaultBuildConstraints getLatestAllowedPlans
+
+-- | Checking should be considered a bad build plan.
+badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))
+             -> void
+             -> IO ()
+badBuildPlan m _ = do
+    mu <- try (check testBuildConstraints m)
+    case mu of
+        Left (_ :: BadBuildPlan) ->
+            return ()
+        Right () ->
+            error "Expected bad build plan."
+
+-- | Check build plan with the given package set getter.
+check :: (Manager -> IO BuildConstraints)
+      -> (BuildConstraints -> IO (Map PackageName PackagePlan))
+      -> IO ()
+check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do
+    bc <- readPlanFile man
+    plans <- getPlans bc
+    bp <- newBuildPlan plans bc
     let bs = Y.encode bp
         ebp' = Y.decodeEither bs
 
@@ -26,14 +60,74 @@ spec = it "works" $ withManager tlsManagerSettings $ \man -> do
     forM_ allPackages $ \name ->
         (name, lookup name (bpPackages bp')) `shouldBe`
         (name, lookup name (bpPackages bp))
-
     bpGithubUsers bp' `shouldBe` bpGithubUsers bp
+
     when (bp' /= bp) $ error "bp' /= bp"
-    bp2 <- updateBuildPlan pkgs bp
+    bp2 <- updateBuildPlan plans bp
     when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
+    checkBuildPlan bp
   where
     dropVersionRanges bp =
         bp { bpPackages = map go $ bpPackages bp }
       where
         go pb = pb { ppConstraints = go' $ ppConstraints pb }
         go' pc = pc { pcVersionRange = anyVersion }
+
+-- | Make a package set from a convenient data structure.
+makePackageSet
+    :: [(String,[Int],[(String,VersionRange)])]
+    -> BuildConstraints
+    -> IO (Map PackageName PackagePlan)
+makePackageSet ps _ =
+    return $
+    M.fromList $
+    map
+        (\(name,ver,deps) ->
+              ( PackageName name
+              , dummyPackage ver $
+                M.fromList $
+                map
+                    (\(dname,dver) ->
+                          ( PackageName dname
+                          , DepInfo {diComponents = S.fromList
+                                             [CompLibrary]
+                                    ,diRange = dver}))
+                    deps))
+        ps
+    where
+        dummyPackage v deps =
+            PackagePlan
+                {ppVersion = Version v []
+                ,ppGithubPings = mempty
+                ,ppUsers = mempty
+                ,ppConstraints =
+                    PackageConstraints
+                        {pcVersionRange = anyV
+                        ,pcMaintainer = Nothing
+                        ,pcTests = Don'tBuild
+                        ,pcHaddocks = Don'tBuild
+                        ,pcBuildBenchmarks = False
+                        ,pcFlagOverrides = mempty
+                        ,pcEnableLibProfile = False}
+                ,ppDesc =
+                    SimpleDesc
+                        {sdPackages = deps
+                        ,sdTools = mempty
+                        ,sdProvidedExes = mempty
+                        ,sdModules = mempty}}
+
+-- | This exact version is required.
+thisV :: [Int] -> VersionRange
+thisV ver = thisVersion (Version ver [])
+
+-- | Accept any version.
+anyV :: VersionRange
+anyV = anyVersion
+
+-- | Test plan.
+testBuildConstraints :: void -> IO BuildConstraints
+testBuildConstraints _ =
+    decodeFileEither
+        (fpToString fp) >>=
+    either throwIO toBC
+    where fp = "test/test-build-constraints.yaml"

test/test-build-constraints.yaml

@@ -0,0 +1,20 @@
+packages:
+    "Test":
+       - foo
+       - bar
+
+global-flags: []
+
+skipped-tests: []
+expected-test-failures: []
+expected-haddock-failures: []
+skipped-benchmarks: []
+skipped-profiling: []
+
+github-users:
+  bar:
+    - demo
+
+package-flags:
+  foo:
+    demo: true