Introduce new ComponentEnabledSpec, removing testEnabled/benchmarkEna…

…bled.

As per an existing TODO in the code, the use of
testEnabled/benchmarkEnabled to indicate if a component
was enabled/disabled by the user command line was an
egregious violation of abstraction.  This commit removes
these two fields, instead passing along the necessary
enabling information with ComponentEnabledSpec instead.

As there were not many uses of testEnabled/benchmarkEnabled,
this was not too difficult to do.

Signed-off-by: Edward Z. Yang <[email protected]>

Cabal/Distribution/PackageDescription.hs

@@ -62,9 +62,7 @@ module Distribution.PackageDescription (
         knownTestTypes,
         emptyTestSuite,
         hasTests,
-        withTest,
         testModules,
-        enabledTests,
 
         -- * Benchmarks
         Benchmark(..),
@@ -74,9 +72,7 @@ module Distribution.PackageDescription (
         knownBenchmarkTypes,
         emptyBenchmark,
         hasBenchmarks,
-        withBenchmark,
         benchmarkModules,
-        enabledBenchmarks,
 
         -- * Build information
         BuildInfo(..),
@@ -553,13 +549,7 @@ exeModules exe = otherModules (buildInfo exe)
 data TestSuite = TestSuite {
         testName      :: String,
         testInterface :: TestSuiteInterface,
-        testBuildInfo :: BuildInfo,
-        testEnabled   :: Bool
-        -- TODO: By having a 'testEnabled' field in the PackageDescription, we
-        -- are mixing build status information (i.e., arguments to 'configure')
-        -- with static package description information. This is undesirable, but
-        -- a better solution is waiting on the next overhaul to the
-        -- GenericPackageDescription -> PackageDescription resolution process.
+        testBuildInfo :: BuildInfo
     }
     deriving (Generic, Show, Read, Eq, Typeable, Data)
 
@@ -597,17 +587,15 @@ instance Monoid TestSuite where
     mempty = TestSuite {
         testName      = mempty,
         testInterface = mempty,
-        testBuildInfo = mempty,
-        testEnabled   = False
+        testBuildInfo = mempty
     }
     mappend = (Semi.<>)
 
 instance Semigroup TestSuite where
     a <> b = TestSuite {
         testName      = combine' testName,
         testInterface = combine  testInterface,
-        testBuildInfo = combine  testBuildInfo,
-        testEnabled   = testEnabled a || testEnabled b
+        testBuildInfo = combine  testBuildInfo
     }
         where combine   field = field a `mappend` field b
               combine' f = case (f a, f b) of
@@ -631,15 +619,6 @@ emptyTestSuite = mempty
 hasTests :: PackageDescription -> Bool
 hasTests = any (buildable . testBuildInfo) . testSuites
 
--- | Get all the enabled test suites from a package.
-enabledTests :: PackageDescription -> [TestSuite]
-enabledTests = filter testEnabled . testSuites
-
--- | Perform an action on each buildable 'TestSuite' in a package.
-withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
-withTest pkg_descr f =
-    mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr
-
 -- | Get all the module names from a test suite.
 testModules :: TestSuite -> [ModuleName]
 testModules test = (case testInterface test of
@@ -699,9 +678,7 @@ testType test = case testInterface test of
 data Benchmark = Benchmark {
         benchmarkName      :: String,
         benchmarkInterface :: BenchmarkInterface,
-        benchmarkBuildInfo :: BuildInfo,
-        benchmarkEnabled   :: Bool
-        -- TODO: See TODO for 'testEnabled'.
+        benchmarkBuildInfo :: BuildInfo
     }
     deriving (Generic, Show, Read, Eq, Typeable, Data)
 
@@ -735,17 +712,15 @@ instance Monoid Benchmark where
     mempty = Benchmark {
         benchmarkName      = mempty,
         benchmarkInterface = mempty,
-        benchmarkBuildInfo = mempty,
-        benchmarkEnabled   = False
+        benchmarkBuildInfo = mempty
     }
     mappend = (Semi.<>)
 
 instance Semigroup Benchmark where
     a <> b = Benchmark {
         benchmarkName      = combine' benchmarkName,
         benchmarkInterface = combine  benchmarkInterface,
-        benchmarkBuildInfo = combine  benchmarkBuildInfo,
-        benchmarkEnabled   = benchmarkEnabled a || benchmarkEnabled b
+        benchmarkBuildInfo = combine  benchmarkBuildInfo
     }
         where combine   field = field a `mappend` field b
               combine' f = case (f a, f b) of
@@ -769,15 +744,6 @@ emptyBenchmark = mempty
 hasBenchmarks :: PackageDescription -> Bool
 hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks
 
--- | Get all the enabled benchmarks from a package.
-enabledBenchmarks :: PackageDescription -> [Benchmark]
-enabledBenchmarks = filter benchmarkEnabled . benchmarks
-
--- | Perform an action on each buildable 'Benchmark' in a package.
-withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()
-withBenchmark pkg_descr f =
-    mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr
-
 -- | Get all the module names from a benchmark.
 benchmarkModules :: Benchmark -> [ModuleName]
 benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
@@ -939,12 +905,10 @@ allBuildInfo pkg_descr = [ bi | lib <- libraries pkg_descr
                               , buildable bi ]
                       ++ [ bi | tst <- testSuites pkg_descr
                               , let bi = testBuildInfo tst
-                              , buildable bi
-                              , testEnabled tst ]
+                              , buildable bi ]
                       ++ [ bi | tst <- benchmarks pkg_descr
                               , let bi = benchmarkBuildInfo tst
-                              , buildable bi
-                              , benchmarkEnabled tst ]
+                              , buildable bi ]
   --FIXME: many of the places where this is used, we actually want to look at
   --       unbuildable bits too, probably need separate functions
 

Cabal/Distribution/PackageDescription/Check.hs

@@ -43,6 +43,7 @@ import Distribution.Simple.Utils hiding (findPackageDesc, notice)
 import Distribution.Version
 import Distribution.Package
 import Distribution.Text
+import Distribution.Simple.LocalBuildInfo hiding (compiler)
 import Language.Haskell.Extension
 
 import Data.Maybe
@@ -1288,7 +1289,7 @@ checkPackageVersions pkg =
     -- open upper bound. To get a typical configuration we finalise
     -- using no package index and the current platform.
     finalised = finalizePackageDescription
-                              [] (const True) buildPlatform
+                              [] defaultComponentEnabled (const True) buildPlatform
                               (unknownCompilerInfo
                                 (CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag)
                               [] pkg

Cabal/Distribution/PackageDescription/Configuration.hs

@@ -48,6 +48,7 @@ import Distribution.Text
 import Distribution.Compat.ReadP as ReadP hiding ( char )
 import qualified Distribution.Compat.ReadP as ReadP ( char )
 import Distribution.Compat.Semigroup as Semi
+import Distribution.Simple.LocalBuildInfo
 
 import Control.Arrow (first)
 import Data.Char ( isAlphaNum )
@@ -211,6 +212,7 @@ instance Semigroup d => Semigroup (DepTestRslt d) where
 resolveWithFlags ::
      [(FlagName,[Bool])]
         -- ^ Domain for each flag name, will be tested in order.
+  -> ComponentEnabledSpec
   -> OS      -- ^ OS as returned by Distribution.System.buildOS
   -> Arch    -- ^ Arch as returned by Distribution.System.buildArch
   -> CompilerInfo  -- ^ Compiler information
@@ -220,7 +222,7 @@ resolveWithFlags ::
   -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
        -- ^ Either the missing dependencies (error case), or a pair of
        -- (set of build targets with dependencies, chosen flag assignments)
-resolveWithFlags dom os arch impl constrs trees checkDeps =
+resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
     either (Left . fromDepMapUnion) Right $ explore (build [] dom)
   where
     extraConstrs = toDepMap constrs
@@ -245,7 +247,7 @@ resolveWithFlags dom os arch impl constrs trees checkDeps =
                 -- apply additional constraints to all dependencies
                 first (`constrainBy` extraConstrs) .
                 simplifyCondTree (env flags)
-            deps = overallDependencies targetSet
+            deps = overallDependencies enabled targetSet
         in case checkDeps (fromDepMap deps) of
              DepOk | null ts   -> Right (targetSet, flags)
                    | otherwise -> tryAll $ map explore ts
@@ -416,15 +418,15 @@ newtype TargetSet a = TargetSet [(DependencyMap, a)]
 
 -- | Combine the target-specific dependencies in a TargetSet to give the
 -- dependencies for the package as a whole.
-overallDependencies :: TargetSet PDTagged -> DependencyMap
-overallDependencies (TargetSet targets) = mconcat depss
+overallDependencies :: ComponentEnabledSpec -> TargetSet PDTagged -> DependencyMap
+overallDependencies enabled (TargetSet targets) = mconcat depss
   where
     (depss, _) = unzip $ filter (removeDisabledSections . snd) targets
     removeDisabledSections :: PDTagged -> Bool
-    removeDisabledSections (Lib _ l)     = buildable (libBuildInfo l)
-    removeDisabledSections (Exe _ e)   = buildable (buildInfo e)
-    removeDisabledSections (Test _ t)  = testEnabled t && buildable (testBuildInfo t)
-    removeDisabledSections (Bench _ b) = benchmarkEnabled b && buildable (benchmarkBuildInfo b)
+    removeDisabledSections (Lib _ l)   = componentEnabled enabled (CLib l)
+    removeDisabledSections (Exe _ e)   = componentEnabled enabled (CExe e)
+    removeDisabledSections (Test _ t)  = componentEnabled enabled (CTest t)
+    removeDisabledSections (Bench _ b) = componentEnabled enabled (CBench b)
     removeDisabledSections PDNull      = True
 
 -- Apply extra constraints to a dependency map.
@@ -505,6 +507,10 @@ flattenTaggedTargets (TargetSet targets) = foldr untag ([], [], [], []) targets
 -- Convert GenericPackageDescription to PackageDescription
 --
 
+-- ezyang: Arguably, this should be:
+--      data PDTagged = PDComp String Component
+--                    | PDNull
+-- Also, what the heck is the String? The componentName?
 data PDTagged = Lib String Library
               | Exe String Executable
               | Test String TestSuite
@@ -549,6 +555,7 @@ instance Semigroup PDTagged where
 --
 finalizePackageDescription ::
      FlagAssignment  -- ^ Explicitly specified flag assignments
+  -> ComponentEnabledSpec
   -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of
                           -- available packages?  If this is unknown then use
                           -- True.
@@ -560,7 +567,7 @@ finalizePackageDescription ::
             (PackageDescription, FlagAssignment)
              -- ^ Either missing dependencies or the resolved package
              -- description along with the flag assignments chosen.
-finalizePackageDescription userflags satisfyDep
+finalizePackageDescription userflags enabled satisfyDep
         (Platform arch os) impl constraints
         (GenericPackageDescription pkg flags libs0 exes0 tests0 bms0) =
     case resolveFlags of
@@ -569,7 +576,7 @@ finalizePackageDescription userflags satisfyDep
                     , executables = exes'
                     , testSuites = tests'
                     , benchmarks = bms'
-                    , buildDepends = fromDepMap (overallDependencies targetSet)
+                    , buildDepends = fromDepMap (overallDependencies enabled targetSet)
                     }
               , flagVals )
 
@@ -582,7 +589,7 @@ finalizePackageDescription userflags satisfyDep
                 ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0
 
     resolveFlags =
-        case resolveWithFlags flagChoices os arch impl constraints condTrees check of
+        case resolveWithFlags flagChoices enabled os arch impl constraints condTrees check of
           Right (targetSet, fs) ->
               let (libs, exes, tests, bms) = flattenTaggedTargets targetSet in
               Right ( (map (\(n,l) -> (libFillInDefaults l) { libName = n }) libs,

Cabal/Distribution/PackageDescription/PrettyPrint.hs

@@ -152,10 +152,10 @@ ppTestSuites suites =
         maybeTestType | testInterface testsuite == mempty = Nothing
                       | otherwise = Just (testType testsuite)
 
-    ppTestSuite (TestSuite _ _ buildInfo' _)
-                    (Just (TestSuite _ _ buildInfo2 _)) =
-            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
-            $+$ ppCustomFields (customFieldsBI buildInfo')
+    ppTestSuite test' (Just test2) =
+            ppDiffFields binfoFieldDescrs
+                (testBuildInfo test') (testBuildInfo test2)
+            $+$ ppCustomFields (customFieldsBI (testBuildInfo test'))
 
     testSuiteMainIs test = case testInterface test of
       TestSuiteExeV10 _ f -> Just f
@@ -182,10 +182,10 @@ ppBenchmarks suites =
         maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
                            | otherwise = Just (benchmarkType benchmark)
 
-    ppBenchmark (Benchmark _ _ buildInfo' _)
-                    (Just (Benchmark _ _ buildInfo2 _)) =
-            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
-            $+$ ppCustomFields (customFieldsBI buildInfo')
+    ppBenchmark bench' (Just bench2) =
+            ppDiffFields binfoFieldDescrs
+                (benchmarkBuildInfo bench') (benchmarkBuildInfo bench2)
+            $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo bench'))
 
     benchmarkMainIs benchmark = case benchmarkInterface benchmark of
       BenchmarkExeV10 _ f -> Just f

Cabal/Distribution/Simple/Bench.hs

@@ -40,9 +40,7 @@ bench args pkg_descr lbi flags = do
     let verbosity         = fromFlag $ benchmarkVerbosity flags
         benchmarkNames    = args
         pkgBenchmarks     = PD.benchmarks pkg_descr
-        enabledBenchmarks = [ t | t <- pkgBenchmarks
-                            , PD.benchmarkEnabled t
-                            , PD.buildable (PD.benchmarkBuildInfo t) ]
+        enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)
 
         -- Run the benchmark
         doBench :: PD.Benchmark -> IO ExitCode

Cabal/Distribution/Simple/Build.hs

@@ -81,7 +81,7 @@ build pkg_descr lbi flags suffixes
   -- a --assume-deps-up-to-date with multiple arguments. Arguably, we should
   -- error early in this case.
   targets <- readBuildTargets pkg_descr (buildArgs flags)
-  (cname, _) <- checkBuildTargets verbosity pkg_descr targets >>= \r -> case r of
+  (cname, _) <- checkBuildTargets verbosity pkg_descr lbi targets >>= \r -> case r of
               [] -> die "In --assume-deps-up-to-date mode you must specify a target"
               [target'] -> return target'
               _ -> die "In --assume-deps-up-to-date mode you can only build a single target"
@@ -106,7 +106,7 @@ build pkg_descr lbi flags suffixes
                  lbi' suffixes comp clbi distPref
  | otherwise = do
   targets  <- readBuildTargets pkg_descr (buildArgs flags)
-  targets' <- checkBuildTargets verbosity pkg_descr targets
+  targets' <- checkBuildTargets verbosity pkg_descr lbi targets
   let componentsToBuild = componentsInBuildOrder lbi (map fst targets')
   info verbosity $ "Component build order: "
                 ++ intercalate ", " (map (showComponentName . componentLocalName) componentsToBuild)
@@ -145,9 +145,10 @@ repl pkg_descr lbi flags suffixes args = do
 
   targets  <- readBuildTargets pkg_descr args
   targets' <- case targets of
+    -- This seems DEEPLY questionable.
     []       -> return $ take 1 [ componentName c
-                                | c <- pkgEnabledComponents pkg_descr ]
-    [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target])
+                                | c <- pkgBuildableComponents pkg_descr ]
+    [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr lbi [target])
     _        -> die $ "The 'repl' command does not support multiple targets at once."
   let componentsToBuild = componentsInBuildOrder lbi targets'
       componentForRepl  = last componentsToBuild

Cabal/Distribution/Simple/BuildTarget.hs

@@ -947,16 +947,17 @@ caseFold = lowercase
 --
 -- Also swizzle into a more convenient form.
 --
-checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]
+checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]
                   -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]
-checkBuildTargets _ pkg []      =
-    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]
+checkBuildTargets _ pkg lbi []      =
+    return [ (componentName c, Nothing) | c <- enabledComponents pkg lbi ]
 
-checkBuildTargets verbosity pkg targets = do
+checkBuildTargets verbosity pkg lbi targets = do
 
     let (enabled, disabled) =
           partitionEithers
-            [ case componentDisabledReason (getComponent pkg cname) of
+            [ case componentDisabledReason (componentEnabledSpec lbi)
+                                           (getComponent pkg cname) of
                 Nothing     -> Left  target'
                 Just reason -> Right (cname, reason)
             | target <- targets