Refactor shared TargetProblem data types into their own module.

cabal-install/Distribution/Client/CmdBench.hs

@@ -8,13 +8,22 @@ module Distribution.Client.CmdBench (
     benchAction,
 
     -- * Internals exposed for testing
-    TargetProblem(..),
+    componentNotBenchmarkProblem,
+    isSubComponentProblem,
+    noBenchmarksProblem,
     selectPackageTargets,
     selectComponentTarget
   ) where
 
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
+         ( renderTargetSelector, showTargetSelector,
+           renderTargetProblemCommon, renderTargetProblemNoneEnabled,
+           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,
+           targetSelectorFilter )
+import Distribution.Client.TargetProblem
+         ( TargetProblem (..), commonTargetProblem, customTargetProblem
+         , noTargetsProblem, noneEnabledTargetProblem )
 
 import Distribution.Client.Setup
          ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
@@ -102,7 +111,7 @@ benchAction ( configFlags, configExFlags, installFlags
                      $ resolveTargets
                          selectPackageTargets
                          selectComponentTarget
-                         TargetProblemCommon
+                         commonTargetProblem
                          elaboratedPlan
                          Nothing
                          targetSelectors
@@ -133,7 +142,7 @@ benchAction ( configFlags, configExFlags, installFlags
 -- or fail if there are no benchmarks or no buildable benchmarks.
 --
 selectPackageTargets :: TargetSelector
-                     -> [AvailableTarget k] -> Either TargetProblem [k]
+                     -> [AvailableTarget k] -> Either BenchTargetProblem [k]
 selectPackageTargets targetSelector targets
 
     -- If there are any buildable benchmark targets then we select those
@@ -142,15 +151,15 @@ selectPackageTargets targetSelector targets
 
     -- If there are benchmarks but none are buildable then we report those
   | not (null targetsBench)
-  = Left (TargetProblemNoneEnabled targetSelector targetsBench)
+  = Left (noneEnabledTargetProblem targetSelector targetsBench)
 
     -- If there are no benchmarks but some other targets then we report that
   | not (null targets)
-  = Left (TargetProblemNoBenchmarks targetSelector)
+  = Left (noBenchmarksProblem targetSelector)
 
     -- If there are no targets at all then we report that
   | otherwise
-  = Left (TargetProblemNoTargets targetSelector)
+  = Left (noTargetsProblem targetSelector)
   where
     targetsBenchBuildable = selectBuildableTargets
                           . filterTargetsKind BenchKind
@@ -168,34 +177,28 @@ selectPackageTargets targetSelector targets
 -- to the basic checks on being buildable etc.
 --
 selectComponentTarget :: SubComponentTarget
-                      -> AvailableTarget k -> Either TargetProblem k
+                      -> AvailableTarget k -> Either BenchTargetProblem k
 selectComponentTarget subtarget@WholeComponent t
   | CBenchName _ <- availableTargetComponentName t
-  = either (Left . TargetProblemCommon) return $
+  = either (Left . commonTargetProblem) return $
            selectComponentTargetBasic subtarget t
   | otherwise
-  = Left (TargetProblemComponentNotBenchmark (availableTargetPackageId t)
-                                             (availableTargetComponentName t))
+  = Left (componentNotBenchmarkProblem
+           (availableTargetPackageId t)
+           (availableTargetComponentName t))
 
 selectComponentTarget subtarget t
-  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)
-                                      (availableTargetComponentName t)
-                                       subtarget)
+  = Left (isSubComponentProblem
+           (availableTargetPackageId t)
+           (availableTargetComponentName t)
+           subtarget)
 
 -- | The various error conditions that can occur when matching a
 -- 'TargetSelector' against 'AvailableTarget's for the @bench@ command.
 --
-data TargetProblem =
-     TargetProblemCommon        TargetProblemCommon
-
-     -- | The 'TargetSelector' matches benchmarks but none are buildable
-   | TargetProblemNoneEnabled  TargetSelector [AvailableTarget ()]
-
-     -- | There are no targets at all
-   | TargetProblemNoTargets    TargetSelector
-
+data BenchProblem =
      -- | The 'TargetSelector' matches targets but no benchmarks
-   | TargetProblemNoBenchmarks TargetSelector
+     TargetProblemNoBenchmarks TargetSelector
 
      -- | The 'TargetSelector' refers to a component that is not a benchmark
    | TargetProblemComponentNotBenchmark PackageId ComponentName
@@ -204,25 +207,43 @@ data TargetProblem =
    | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget
   deriving (Eq, Show)
 
-reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
+
+type BenchTargetProblem = TargetProblem BenchProblem
+
+noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem
+noBenchmarksProblem = customTargetProblem . TargetProblemNoBenchmarks
+
+componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem
+componentNotBenchmarkProblem pkgid name = customTargetProblem $
+  TargetProblemComponentNotBenchmark pkgid name
+
+isSubComponentProblem
+  :: PackageId
+  -> ComponentName
+  -> SubComponentTarget
+  -> TargetProblem BenchProblem
+isSubComponentProblem pkgid name subcomponent = customTargetProblem $
+    TargetProblemIsSubComponent pkgid name subcomponent
+
+reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a
 reportTargetProblems verbosity =
     die' verbosity . unlines . map renderTargetProblem
 
-renderTargetProblem :: TargetProblem -> String
-renderTargetProblem (TargetProblemCommon problem) =
+renderTargetProblem :: BenchTargetProblem -> String
+renderTargetProblem (CommonProblem problem) =
     renderTargetProblemCommon "run" problem
 
-renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
+renderTargetProblem (NoneEnabled targetSelector targets) =
     renderTargetProblemNoneEnabled "benchmark" targetSelector targets
 
-renderTargetProblem (TargetProblemNoBenchmarks targetSelector) =
+renderTargetProblem (CustomProblem (TargetProblemNoBenchmarks targetSelector)) =
     "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector
  ++ "' which refers to " ++ renderTargetSelector targetSelector
  ++ " because "
  ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
  ++ " not contain any benchmarks."
 
-renderTargetProblem (TargetProblemNoTargets targetSelector) =
+renderTargetProblem (NoTargets targetSelector) =
     case targetSelectorFilter targetSelector of
       Just kind | kind /= BenchKind
         -> "The bench command is for running benchmarks, but the target '"
@@ -231,15 +252,15 @@ renderTargetProblem (TargetProblemNoTargets targetSelector) =
 
       _ -> renderTargetProblemNoTargets "benchmark" targetSelector
 
-renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) =
+renderTargetProblem (CustomProblem (TargetProblemComponentNotBenchmark pkgid cname)) =
     "The bench command is for running benchmarks, but the target '"
  ++ showTargetSelector targetSelector ++ "' refers to "
  ++ renderTargetSelector targetSelector ++ " from the package "
  ++ prettyShow pkgid ++ "."
   where
     targetSelector = TargetComponent pkgid cname WholeComponent
 
-renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
+renderTargetProblem (CustomProblem (TargetProblemIsSubComponent pkgid cname subtarget)) =
     "The bench command can only run benchmarks as a whole, "
  ++ "not files or modules within them, but the target '"
  ++ showTargetSelector targetSelector ++ "' refers to "

cabal-install/Distribution/Client/CmdBuild.hs

@@ -6,7 +6,6 @@ module Distribution.Client.CmdBuild (
     buildAction,
 
     -- * Internals exposed for testing
-    TargetProblem(..),
     selectPackageTargets,
     selectComponentTarget
   ) where
@@ -15,6 +14,12 @@ import Prelude ()
 import Distribution.Client.Compat.Prelude
 
 import Distribution.Client.ProjectOrchestration
+import Distribution.Client.TargetProblem
+         ( TargetProblem'
+         , commonTargetProblem
+         , noTargetsProblem
+         , noneEnabledTargetProblem
+         )
 import Distribution.Client.CmdErrorMessages
 
 import Distribution.Client.Setup
@@ -132,11 +137,11 @@ buildAction
 
             -- Interpret the targets on the command line as build targets
             -- (as opposed to say repl or haddock targets).
-            targets <- either (reportTargetProblems verbosity) return
+            targets <- either (reportBuildTargetProblems verbosity) return
                      $ resolveTargets
                          selectPackageTargets
                          selectComponentTarget
-                         TargetProblemCommon
+                         commonTargetProblem
                          elaboratedPlan
                          Nothing
                          targetSelectors
@@ -175,7 +180,7 @@ buildAction
 -- components
 --
 selectPackageTargets :: TargetSelector
-                     -> [AvailableTarget k] -> Either TargetProblem [k]
+                     -> [AvailableTarget k] -> Either TargetProblem' [k]
 selectPackageTargets targetSelector targets
 
     -- If there are any buildable targets then we select those
@@ -184,11 +189,11 @@ selectPackageTargets targetSelector targets
 
     -- If there are targets but none are buildable then we report those
   | not (null targets)
-  = Left (TargetProblemNoneEnabled targetSelector targets')
+  = Left (noneEnabledTargetProblem targetSelector targets')
 
     -- If there are no targets at all then we report that
   | otherwise
-  = Left (TargetProblemNoTargets targetSelector)
+  = Left (noTargetsProblem targetSelector)
   where
     targets'         = forgetTargetsDetail targets
     targetsBuildable = selectBuildableTargetsWith
@@ -208,36 +213,14 @@ selectPackageTargets targetSelector targets
 -- For the @build@ command we just need the basic checks on being buildable etc.
 --
 selectComponentTarget :: SubComponentTarget
-                      -> AvailableTarget k -> Either TargetProblem k
+                      -> AvailableTarget k -> Either TargetProblem' k
 selectComponentTarget subtarget =
-    either (Left . TargetProblemCommon) Right
+    either (Left . commonTargetProblem) Right
   . selectComponentTargetBasic subtarget
 
-
--- | The various error conditions that can occur when matching a
--- 'TargetSelector' against 'AvailableTarget's for the @build@ command.
---
-data TargetProblem =
-     TargetProblemCommon       TargetProblemCommon
-
-     -- | The 'TargetSelector' matches targets but none are buildable
-   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
-
-     -- | There are no targets at all
-   | TargetProblemNoTargets   TargetSelector
-  deriving (Eq, Show)
-
-reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
-reportTargetProblems verbosity =
-    die' verbosity . unlines . map renderTargetProblem
-
-renderTargetProblem :: TargetProblem -> String
-renderTargetProblem (TargetProblemCommon problem) =
-    renderTargetProblemCommon "build" problem
-renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
-    renderTargetProblemNoneEnabled "build" targetSelector targets
-renderTargetProblem(TargetProblemNoTargets targetSelector) =
-    renderTargetProblemNoTargets "build" targetSelector
+reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
+reportBuildTargetProblems verbosity problems =
+  reportTargetProblems verbosity "build" problems
 
 reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
 reportCannotPruneDependencies verbosity =

cabal-install/Distribution/Client/CmdErrorMessages.hs

@@ -1,4 +1,7 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
 
 -- | Utilities to help format error messages for the various CLI commands.
 --
@@ -10,20 +13,31 @@ module Distribution.Client.CmdErrorMessages (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import Distribution.Client.ProjectOrchestration
+import Distribution.Client.ProjectPlanning
+         ( AvailableTarget(..), AvailableTargetStatus(..),
+           CannotPruneDependencies(..), TargetRequested(..) )
+import Distribution.Client.TargetSelector
+         ( SubComponentTarget(..) )
+import Distribution.Client.TargetProblem
+         ( TargetProblemCommon(..), TargetProblem(..), TargetProblem' )
 import Distribution.Client.TargetSelector
-         ( ComponentKindFilter, componentKind, showTargetSelector )
+         ( ComponentKind(..), ComponentKindFilter, TargetSelector(..),
+           componentKind, showTargetSelector )
 
 import Distribution.Package
-         ( packageId, PackageName, packageName )
+         ( PackageId, packageId, PackageName, packageName )
+import Distribution.Simple.Utils
+         ( die' )
 import Distribution.Types.ComponentName
-         ( showComponentName )
+         ( ComponentName(..), showComponentName )
 import Distribution.Types.LibraryName
          ( LibraryName(..) )
 import Distribution.Solver.Types.OptionalStanza
          ( OptionalStanza(..) )
 import Distribution.Pretty
          ( prettyShow )
+import Distribution.Verbosity
+         ( Verbosity )
 
 import qualified Data.List.NonEmpty as NE
 import Data.Function (on)
@@ -191,6 +205,28 @@ renderComponentKind Plural ckind = case ckind of
   BenchKind -> "benchmarks"
 
 
+-------------------------------------------------------
+-- Renderering error messages for TargetProblem
+--
+
+-- | Default implementation of 'reportTargetProblems' simply renders one problem per line.
+reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a
+reportTargetProblems verbosity verb =
+  die' verbosity . unlines . map (renderTargetProblem verb)
+
+-- | Default implementation of 'renderTargetProblem'.
+renderTargetProblem :: String -> TargetProblem' -> String
+renderTargetProblem verb = \case
+  (CommonProblem problem) ->
+    renderTargetProblemCommon verb problem
+  (NoneEnabled targetSelector targets) ->
+    renderTargetProblemNoneEnabled verb targetSelector targets
+  (NoTargets targetSelector) ->
+    renderTargetProblemNoTargets verb targetSelector
+  (CustomProblem ()) ->
+    ""
+
+
 -------------------------------------------------------
 -- Renderering error messages for TargetProblemCommon
 --