Merge pull request #3277 from grayjay/solver-dsl-test-suites

Simplify representation of test suites in the solver DSL

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs

@@ -3,6 +3,7 @@
 module UnitTests.Distribution.Client.Dependency.Modular.DSL (
     ExampleDependency(..)
   , Dependencies(..)
+  , ExTest(..)
   , ExPreference(..)
   , ExampleDb
   , ExampleVersionRange
@@ -18,6 +19,8 @@ module UnitTests.Distribution.Client.Dependency.Modular.DSL (
   , exResolve
   , extractInstallPlan
   , withSetupDeps
+  , withTest
+  , withTests
   ) where
 
 -- base
@@ -111,9 +114,6 @@ data ExampleDependency =
     -- | Dependencies indexed by a flag
   | ExFlag ExampleFlagName Dependencies Dependencies
 
-    -- | Dependency if tests are enabled
-  | ExTest ExampleTestName [ExampleDependency]
-
     -- | Dependency on a language extension
   | ExExt Extension
 
@@ -124,6 +124,8 @@ data ExampleDependency =
   | ExPkg (ExamplePkgName, ExamplePkgVersion)
   deriving Show
 
+data ExTest = ExTest ExampleTestName [ExampleDependency]
+
 exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
        -> ExampleDependency
 exFlag n t e = ExFlag n (Buildable t) (Buildable e)
@@ -155,6 +157,15 @@ withSetupDeps ex setupDeps = ex {
       exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps
     }
 
+withTest :: ExampleAvailable -> ExTest -> ExampleAvailable
+withTest ex test = withTests ex [test]
+
+withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable
+withTests ex tests =
+  let testCDs = CD.fromList [(CD.ComponentTest name, deps)
+                            | ExTest name deps <- tests]
+  in ex { exAvDeps = exAvDeps ex <> testCDs }
+
 -- | An installed package in 'ExampleDb'; construct me with 'exInst'.
 data ExampleInstalled = ExInst {
     exInstName         :: ExamplePkgName
@@ -195,7 +206,8 @@ exDbPkgs = map (either exInstName exAvName)
 
 exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage
 exAvSrcPkg ex =
-    let (libraryDeps, testSuites, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
+    let (libraryDeps, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
+        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
     in SourcePackage {
            packageInfoId        = exAvPkgId ex
          , packageSource        = LocalTarballPackage "<<path>>"
@@ -212,8 +224,8 @@ exAvSrcPkg ex =
                        C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex))
                      }
                  }
-             , C.genPackageFlags = nub $ concatMap extractFlags
-                                   (CD.libraryDeps (exAvDeps ex))
+             , C.genPackageFlags = nub $ concatMap extractFlags $
+                                   CD.libraryDeps (exAvDeps ex) ++ concatMap snd testSuites
              , C.condLibraries   = [(exAvName ex, mkCondTree (extsLib exts <> langLib mlang <> pcpkgLib pcpkgs)
                                                      disableLib
                                                      (Buildable libraryDeps))]
@@ -229,29 +241,25 @@ exAvSrcPkg ex =
     -- the dependencies of the test suites and extensions.
     splitTopLevel :: [ExampleDependency]
                   -> ( [ExampleDependency]
-                     , [(ExampleTestName, [ExampleDependency])]
                      , [Extension]
                      , Maybe Language
                      , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config
                      )
     splitTopLevel [] =
-        ([], [], [], Nothing, [])
-    splitTopLevel (ExTest t a:deps) =
-      let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps
-      in (other, (t, a):testSuites, exts, lang, pcpkgs)
+        ([], [], Nothing, [])
     splitTopLevel (ExExt ext:deps) =
-      let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps
-      in (other, testSuites, ext:exts, lang, pcpkgs)
+      let (other, exts, lang, pcpkgs) = splitTopLevel deps
+      in (other, ext:exts, lang, pcpkgs)
     splitTopLevel (ExLang lang:deps) =
         case splitTopLevel deps of
-            (other, testSuites, exts, Nothing, pcpkgs) -> (other, testSuites, exts, Just lang, pcpkgs)
+            (other, exts, Nothing, pcpkgs) -> (other, exts, Just lang, pcpkgs)
             _ -> error "Only 1 Language dependency is supported"
     splitTopLevel (ExPkg pkg:deps) =
-      let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps
-      in (other, testSuites, exts, lang, pkg:pcpkgs)
+      let (other, exts, lang, pcpkgs) = splitTopLevel deps
+      in (other, exts, lang, pkg:pcpkgs)
     splitTopLevel (dep:deps) =
-      let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps
-      in (dep:other, testSuites, exts, lang, pcpkgs)
+      let (other, exts, lang, pcpkgs) = splitTopLevel deps
+      in (dep:other, exts, lang, pcpkgs)
 
     -- Extract the total set of flags used
     extractFlags :: ExampleDependency -> [C.Flag]
@@ -268,7 +276,6 @@ exAvSrcPkg ex =
         deps :: Dependencies -> [ExampleDependency]
         deps NotBuildable = []
         deps (Buildable ds) = ds
-    extractFlags (ExTest _ a)   = concatMap extractFlags a
     extractFlags (ExExt _)      = []
     extractFlags (ExLang _)     = []
     extractFlags (ExPkg _)      = []
@@ -326,8 +333,6 @@ exAvSrcPkg ex =
     splitDeps (ExFlag f a b:deps) =
       let (directDeps, flaggedDeps) = splitDeps deps
       in (directDeps, (f, a, b):flaggedDeps)
-    splitDeps (ExTest _ _:_) =
-      error "Unexpected nested test"
     splitDeps (_:deps) = splitDeps deps
 
     -- Currently we only support simple setup dependencies

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/QuickCheck.hs

@@ -168,6 +168,7 @@ arbitraryExInst pn v pkgs = do
 arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency])
 arbitraryComponentDeps (TestDb []) = return $ CD.fromList []
 arbitraryComponentDeps db =
+    -- CD.fromList combines duplicate components.
     CD.fromList <$> boundedListOf 3 (arbitraryComponentDep db)
 
 arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])
@@ -175,20 +176,18 @@ arbitraryComponentDep db = do
   comp <- arbitrary
   deps <- case comp of
             ComponentSetup -> smallListOf (arbitraryExDep db Setup)
-            _              -> boundedListOf 5 (arbitraryExDep db TopLevel)
+            _              -> boundedListOf 5 (arbitraryExDep db NonSetup)
   return (comp, deps)
 
 -- | Location of an 'ExampleDependency'. It determines which values are valid.
-data ExDepLocation = TopLevel | Nested | Setup
+data ExDepLocation = Setup | NonSetup
 
 arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
 arbitraryExDep db@(TestDb pkgs) level =
-  let test = ExTest <$> arbitraryTestName
-                    <*> smallListOf (arbitraryExDep db Nested)
-      flag = ExFlag <$> arbitraryFlagName
+  let flag = ExFlag <$> arbitraryFlagName
                     <*> arbitraryDeps db
                     <*> arbitraryDeps db
-      nonNested = [
+      other = [
             ExAny . unPN <$> elements (map getName pkgs)
 
           -- existing version
@@ -200,19 +199,15 @@ arbitraryExDep db@(TestDb pkgs) level =
           ]
   in oneof $
       case level of
-        TopLevel -> test : flag : nonNested
-        Nested -> flag : nonNested
-        Setup -> nonNested
+        NonSetup -> flag : other
+        Setup -> other
 
 arbitraryDeps :: TestDb -> Gen Dependencies
 arbitraryDeps db = frequency
     [ (1, return NotBuildable)
-    , (20, Buildable <$> smallListOf (arbitraryExDep db Nested))
+    , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetup))
     ]
 
-arbitraryTestName :: Gen String
-arbitraryTestName = (:[]) <$> elements ['A'..'E']
-
 arbitraryFlagName :: Gen String
 arbitraryFlagName = (:[]) <$> elements ['A'..'E']
 
@@ -268,8 +263,6 @@ instance Arbitrary ExampleDependency where
 
   shrink (ExAny _) = []
   shrink (ExFix pn _) = [ExAny pn]
-  shrink (ExTest testName deps) =
-      deps ++ [ExTest testName deps' | deps' <- shrink deps]
   shrink (ExFlag flag th el) =
          deps th ++ deps el
       ++ [ExFlag flag th' el | th' <- shrink th]

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs

@@ -330,11 +330,11 @@ db5 = [
     Right $ exAv "A" 1 []
   , Right $ exAv "A" 2 []
   , Right $ exAv "B" 1 []
-  , Right $ exAv "C" 1 [ExTest "testC" [ExAny "A"]]
-  , Right $ exAv "D" 1 [ExTest "testD" [ExFix "B" 2]]
-  , Right $ exAv "E" 1 [ExFix "A" 1, ExTest "testE" [ExAny "A"]]
-  , Right $ exAv "F" 1 [ExFix "A" 1, ExTest "testF" [ExFix "A" 2]]
-  , Right $ exAv "G" 1 [ExFix "A" 2, ExTest "testG" [ExAny "A"]]
+  , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"]
+  , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2]
+  , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"]
+  , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2]
+  , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"]
   ]
 
 -- Now the _dependencies_ have test suites
@@ -349,7 +349,7 @@ db6 :: ExampleDb
 db6 = [
     Right $ exAv "A" 1 []
   , Right $ exAv "A" 2 []
-  , Right $ exAv "B" 1 [ExTest "testA" [ExAny "A"]]
+  , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"]
   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]
   , Right $ exAv "D" 1 [ExAny "B"]
   ]
@@ -532,13 +532,13 @@ testBuildable testName unavailableDep =
   where
     expected = Just [("false-dep", 1), ("pkg", 1)]
     db = [
-        Right $ exAv "pkg" 1 [
-                   unavailableDep
-                 , ExFlag "enable-lib" (Buildable []) NotBuildable
-                 , ExTest "test" [exFlag "enable-lib"
-                                      [ExAny "true-dep"]
-                                      [ExAny "false-dep"]]
-                 ]
+        Right $ exAv "pkg" 1
+            [ unavailableDep
+            , ExFlag "enable-lib" (Buildable []) NotBuildable ]
+         `withTest`
+            ExTest "test" [exFlag "enable-lib"
+                              [ExAny "true-dep"]
+                              [ExAny "false-dep"]]
       , Right $ exAv "true-dep" 1 []
       , Right $ exAv "false-dep" 1 []
       ]
@@ -550,8 +550,9 @@ dbBuildable1 = [
     Right $ exAv "pkg" 1
         [ ExAny "unknown"
         , ExFlag "flag1" (Buildable []) NotBuildable
-        , ExFlag "flag2" (Buildable []) NotBuildable
-        , ExTest "optional-test"
+        , ExFlag "flag2" (Buildable []) NotBuildable]
+     `withTests`
+        [ ExTest "optional-test"
               [ ExAny "unknown"
               , ExFlag "flag1"
                     (Buildable [])