Refactor shared TargetProblem data types into their own module.

Moved "problem rendering" to CmdErrorMessages module

Additions by Oleg Grenrus:

- There were CommonTargetProblem, but now
  TargetProblem has an extension point so we can have just one type.
  A lot of code is simplified as we don't need to pass in injection
  from CommonTargetProblem to the resulting `err` type.

Author: m-renaud

cabal-install/Distribution/Client/CmdBench.hs

@@ -8,7 +8,9 @@ module Distribution.Client.CmdBench (
     benchAction,
 
     -- * Internals exposed for testing
-    TargetProblem(..),
+    componentNotBenchmarkProblem,
+    isSubComponentProblem,
+    noBenchmarksProblem,
     selectPackageTargets,
     selectComponentTarget
   ) where
@@ -18,7 +20,11 @@ import Prelude ()
 
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
-
+         ( renderTargetSelector, showTargetSelector, renderTargetProblem,
+           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,
+           targetSelectorFilter )
+import Distribution.Client.TargetProblem
+         ( TargetProblem (..) )
 import Distribution.Client.NixStyleOptions
          ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.Setup
@@ -98,7 +104,6 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do
                      $ resolveTargets
                          selectPackageTargets
                          selectComponentTarget
-                         TargetProblemCommon
                          elaboratedPlan
                          Nothing
                          targetSelectors
@@ -126,7 +131,7 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do
 -- 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
@@ -139,7 +144,7 @@ selectPackageTargets targetSelector targets
 
     -- 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
@@ -161,34 +166,27 @@ 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 $
-           selectComponentTargetBasic subtarget t
+  = 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
@@ -197,42 +195,57 @@ data TargetProblem =
    | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget
   deriving (Eq, Show)
 
-reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
-reportTargetProblems verbosity =
-    die' verbosity . unlines . map renderTargetProblem
 
-renderTargetProblem :: TargetProblem -> String
-renderTargetProblem (TargetProblemCommon problem) =
-    renderTargetProblemCommon "run" problem
+type BenchTargetProblem = TargetProblem BenchProblem
 
-renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
-    renderTargetProblemNoneEnabled "benchmark" targetSelector targets
+noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem
+noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks
 
-renderTargetProblem (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."
+componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem
+componentNotBenchmarkProblem pkgid name = CustomTargetProblem $
+  TargetProblemComponentNotBenchmark pkgid name
 
-renderTargetProblem (TargetProblemNoTargets targetSelector) =
+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 renderBenchTargetProblem
+
+renderBenchTargetProblem :: BenchTargetProblem -> String
+renderBenchTargetProblem (TargetProblemNoTargets targetSelector) =
     case targetSelectorFilter targetSelector of
       Just kind | kind /= BenchKind
         -> "The bench command is for running benchmarks, but the target '"
            ++ showTargetSelector targetSelector ++ "' refers to "
            ++ renderTargetSelector targetSelector ++ "."
 
       _ -> renderTargetProblemNoTargets "benchmark" targetSelector
+renderBenchTargetProblem problem =
+    renderTargetProblem "benchmark" renderBenchProblem problem
+
+renderBenchProblem :: BenchProblem -> String
+renderBenchProblem (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 (TargetProblemComponentNotBenchmark pkgid cname) =
+renderBenchProblem (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) =
+renderBenchProblem (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

@@ -7,7 +7,6 @@ module Distribution.Client.CmdBuild (
     buildAction,
 
     -- * Internals exposed for testing
-    TargetProblem(..),
     selectPackageTargets,
     selectComponentTarget
   ) where
@@ -16,6 +15,8 @@ import Prelude ()
 import Distribution.Client.Compat.Prelude
 
 import Distribution.Client.ProjectOrchestration
+import Distribution.Client.TargetProblem
+         ( TargetProblem (..), TargetProblem' )
 import Distribution.Client.CmdErrorMessages
 
 import Distribution.Client.NixStyleOptions
@@ -112,11 +113,10 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo
 
             -- 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
                          elaboratedPlan
                          Nothing
                          targetSelectors
@@ -152,7 +152,7 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo
 -- 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
@@ -185,36 +185,12 @@ selectPackageTargets targetSelector targets
 -- For the @build@ command we just need the basic checks on being buildable etc.
 --
 selectComponentTarget :: SubComponentTarget
-                      -> AvailableTarget k -> Either TargetProblem k
-selectComponentTarget subtarget =
-    either (Left . TargetProblemCommon) Right
-  . selectComponentTargetBasic subtarget
+                      -> AvailableTarget k -> Either TargetProblem' k
+selectComponentTarget = selectComponentTargetBasic
 
-
--- | 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,14 +13,23 @@ 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
+         ( 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
@@ -189,30 +201,46 @@ renderComponentKind Plural ckind = case ckind of
 
 
 -------------------------------------------------------
--- Renderering error messages for TargetProblemCommon
+-- Renderering error messages for TargetProblem
 --
 
-renderTargetProblemCommon :: String -> TargetProblemCommon -> String
-renderTargetProblemCommon verb (TargetNotInProject pkgname) =
+-- | 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 absurd)
+
+-- | Default implementation of 'renderTargetProblem'.
+renderTargetProblem
+    :: String           -- ^ verb
+    -> (a -> String)    -- ^ how to render custom problems
+    -> TargetProblem a
+    -> String
+renderTargetProblem _verb f (CustomTargetProblem x) = f x
+renderTargetProblem verb  _ (TargetProblemNoneEnabled targetSelector targets) =
+    renderTargetProblemNoneEnabled verb targetSelector targets
+renderTargetProblem verb  _ (TargetProblemNoTargets targetSelector) =
+    renderTargetProblemNoTargets verb targetSelector
+
+renderTargetProblem verb _ (TargetNotInProject pkgname) =
     "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "
  ++ "in this project (either directly or indirectly). If you want to add it "
  ++ "to the project then edit the cabal.project file."
 
-renderTargetProblemCommon verb (TargetAvailableInIndex pkgname) =
+renderTargetProblem verb _ (TargetAvailableInIndex pkgname) =
     "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "
  ++ "in this project (either directly or indirectly), but it is in the current "
  ++ "package index. If you want to add it to the project then edit the "
  ++ "cabal.project file."
 
-renderTargetProblemCommon verb (TargetComponentNotProjectLocal pkgid cname _) =
+renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) =
     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "
  ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal "
  ++ "does not currently support building test suites or benchmarks of "
  ++ "non-local dependencies. To run test suites or benchmarks from "
  ++ "dependencies you can unpack the package locally and adjust the "
  ++ "cabal.project file to include that package directory."
 
-renderTargetProblemCommon verb (TargetComponentNotBuildable pkgid cname _) =
+renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) =
     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is "
  ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid)
  ++ ".cabal' file (at least for the current configuration). If you believe it "
@@ -221,7 +249,7 @@ renderTargetProblemCommon verb (TargetComponentNotBuildable pkgid cname _) =
  ++ "edit the .cabal file to declare it as buildable and fix any resulting "
  ++ "build problems."
 
-renderTargetProblemCommon verb (TargetOptionalStanzaDisabledByUser _ cname _) =
+renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) =
     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because "
  ++ "building " ++ compkinds ++ " has been explicitly disabled in the "
  ++ "configuration. You can adjust this configuration in the "
@@ -234,7 +262,7 @@ renderTargetProblemCommon verb (TargetOptionalStanzaDisabledByUser _ cname _) =
    where
      compkinds = renderComponentKind Plural (componentKind cname)
 
-renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname _) =
+renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) =
     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "
  ++ "solver did not find a plan that included the " ++ compkinds
  ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with "
@@ -247,7 +275,7 @@ renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname
    where
      compkinds = renderComponentKind Plural (componentKind cname)
 
-renderTargetProblemCommon verb (TargetProblemUnknownComponent pkgname ecname) =
+renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) =
     "Cannot " ++ verb ++ " the "
  ++ (case ecname of
       Left ucname -> "component " ++ prettyShow ucname
@@ -259,13 +287,13 @@ renderTargetProblemCommon verb (TargetProblemUnknownComponent pkgname ecname) =
       Right cname -> renderComponentKind Singular (componentKind cname))
  ++ " with that name."
 
-renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) =
+renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) =
     "Internal error when trying to " ++ verb ++ " the package "
   ++ prettyShow pkgid ++ ". The package is not in the set of available targets "
   ++ "for the project plan, which would suggest an inconsistency "
   ++ "between readTargetSelectors and resolveTargets."
 
-renderTargetProblemCommon verb (TargetProblemNoSuchComponent pkgid cname) =
+renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) =
     "Internal error when trying to " ++ verb ++ " the "
   ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid
   ++ ". The package,component pair is not in the set of available targets "