Refactor TargetProblemCommon into TargetProblem.hs.

Also:
- Rename ExtensibleTargetProblem -> TargetProblem
- Rename TargetProblem alias -> TargetProblem' (following convention)
- Shorted data constructor names it TargetProblem
- Moved "problem rendering" to CmdErrorMessages module

cabal-install/Distribution/Client/CmdBench.hs

@@ -17,8 +17,12 @@ module Distribution.Client.CmdBench (
 
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
+         ( renderTargetSelector, showTargetSelector,
+           renderTargetProblemCommon, renderTargetProblemNoneEnabled,
+           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,
+           targetSelectorFilter )
 import Distribution.Client.TargetProblem
-         ( ExtensibleTargetProblem (..), commonTargetProblem
+         ( TargetProblem (..), commonTargetProblem, customTargetProblem
          , noTargetsProblem, noneEnabledTargetProblem )
 
 import Distribution.Client.Setup
@@ -204,43 +208,42 @@ data BenchProblem =
   deriving (Eq, Show)
 
 
-type BenchTargetProblem = ExtensibleTargetProblem BenchProblem
+type BenchTargetProblem = TargetProblem BenchProblem
 
-noBenchmarksProblem :: TargetSelector -> ExtensibleTargetProblem BenchProblem
-noBenchmarksProblem = ExtensibleTargetProblemCustomProblem . TargetProblemNoBenchmarks
+noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem
+noBenchmarksProblem = customTargetProblem . TargetProblemNoBenchmarks
 
-componentNotBenchmarkProblem :: PackageId -> ComponentName -> ExtensibleTargetProblem BenchProblem
-componentNotBenchmarkProblem pkgid name = ExtensibleTargetProblemCustomProblem $
+componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem
+componentNotBenchmarkProblem pkgid name = customTargetProblem $
   TargetProblemComponentNotBenchmark pkgid name
 
 isSubComponentProblem
   :: PackageId
   -> ComponentName
   -> SubComponentTarget
-  -> ExtensibleTargetProblem BenchProblem
-isSubComponentProblem pkgid name subcomponent = ExtensibleTargetProblemCustomProblem $
+  -> TargetProblem BenchProblem
+isSubComponentProblem pkgid name subcomponent = customTargetProblem $
     TargetProblemIsSubComponent pkgid name subcomponent
 
 reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a
 reportTargetProblems verbosity =
     die' verbosity . unlines . map renderTargetProblem
 
 renderTargetProblem :: BenchTargetProblem -> String
-renderTargetProblem (ExtensibleTargetProblemCommon problem) =
+renderTargetProblem (CommonProblem problem) =
     renderTargetProblemCommon "run" problem
 
-renderTargetProblem (ExtensibleTargetProblemNoneEnabled targetSelector targets) =
+renderTargetProblem (NoneEnabled targetSelector targets) =
     renderTargetProblemNoneEnabled "benchmark" targetSelector targets
 
-renderTargetProblem (ExtensibleTargetProblemCustomProblem
-                      (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 (ExtensibleTargetProblemNoTargets targetSelector) =
+renderTargetProblem (NoTargets targetSelector) =
     case targetSelectorFilter targetSelector of
       Just kind | kind /= BenchKind
         -> "The bench command is for running benchmarks, but the target '"
@@ -249,17 +252,15 @@ renderTargetProblem (ExtensibleTargetProblemNoTargets targetSelector) =
 
       _ -> renderTargetProblemNoTargets "benchmark" targetSelector
 
-renderTargetProblem (ExtensibleTargetProblemCustomProblem
-                      (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 "
  ++ display pkgid ++ "."
   where
     targetSelector = TargetComponent pkgid cname WholeComponent
 
-renderTargetProblem  (ExtensibleTargetProblemCustomProblem
-                       (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

@@ -15,11 +15,10 @@ import Distribution.Client.Compat.Prelude
 
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.TargetProblem
-         ( TargetProblem
+         ( TargetProblem'
          , commonTargetProblem
          , noTargetsProblem
          , noneEnabledTargetProblem
-         , reportTargetProblems
          )
 import Distribution.Client.CmdErrorMessages
 
@@ -181,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
@@ -214,12 +213,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
+                      -> AvailableTarget k -> Either TargetProblem' k
 selectComponentTarget subtarget =
     either (Left . commonTargetProblem) Right
   . selectComponentTargetBasic subtarget
 
-reportBuildTargetProblems :: Verbosity -> [TargetProblem] -> IO a
+reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
 reportBuildTargetProblems verbosity problems =
   reportTargetProblems verbosity "build" problems
 

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.Deprecated.Text
          ( display )
+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
 --

cabal-install/Distribution/Client/CmdHaddock.hs

@@ -15,11 +15,10 @@ module Distribution.Client.CmdHaddock (
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
 import Distribution.Client.TargetProblem
-         ( TargetProblem
+         ( TargetProblem'
          , commonTargetProblem
          , noTargetsProblem
          , noneEnabledTargetProblem
-         , reportTargetProblems
          )
 
 import Distribution.Client.NixStyleOptions
@@ -134,7 +133,7 @@ haddockAction ( configFlags, configExFlags, installFlags
 -- We do similarly for test-suites, benchmarks and foreign libs.
 --
 selectPackageTargets  :: HaddockFlags -> TargetSelector
-                      -> [AvailableTarget k] -> Either TargetProblem [k]
+                      -> [AvailableTarget k] -> Either TargetProblem' [k]
 selectPackageTargets haddockFlags targetSelector targets
 
     -- If there are any buildable targets then we select those
@@ -184,11 +183,11 @@ selectPackageTargets haddockFlags targetSelector targets
 -- etc.
 --
 selectComponentTarget :: SubComponentTarget
-                      -> AvailableTarget k -> Either TargetProblem k
+                      -> AvailableTarget k -> Either TargetProblem' k
 selectComponentTarget subtarget =
     either (Left . commonTargetProblem) Right
   . selectComponentTargetBasic subtarget
 
-reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem] -> IO a
+reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
 reportBuildDocumentationTargetProblems verbosity problems =
   reportTargetProblems verbosity "build documentation for" problems

cabal-install/Distribution/Client/CmdInstall.hs

@@ -28,12 +28,11 @@ import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
 import Distribution.Client.CmdSdist
 import Distribution.Client.TargetProblem
-         ( TargetProblem,
-           ExtensibleTargetProblem (ExtensibleTargetProblemCommon),
+         ( TargetProblem',
+           TargetProblem (CommonProblem),
            commonTargetProblem,
            noneEnabledTargetProblem,
-           noTargetsProblem,
-           reportTargetProblems )
+           noTargetsProblem )
 
 import Distribution.Client.CmdInstall.ClientInstallFlags
 import Distribution.Client.CmdInstall.ClientInstallTargetSelector
@@ -524,12 +523,12 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS
       -- Not everything is local.
       let
         (errs', hackageNames) = partitionEithers . flip fmap errs $ \case
-          ExtensibleTargetProblemCommon (TargetAvailableInIndex name) -> Right name
+          CommonProblem (TargetAvailableInIndex name) -> Right name
           err -> Left err
 
       -- report incorrect case for known package.
       for_ errs' $ \case
-        ExtensibleTargetProblemCommon (TargetNotInProject hn) ->
+        CommonProblem (TargetNotInProject hn) ->
           case searchByName (packageIndex pkgDb) (unPackageName hn) of
             [] -> return ()
             xs -> die' verbosity . concat $
@@ -937,7 +936,7 @@ getPackageDbStack compilerId storeDirFlag logsDirFlag = do
 --
 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
@@ -971,12 +970,12 @@ selectPackageTargets targetSelector targets
 --
 selectComponentTarget
   :: SubComponentTarget
-  -> AvailableTarget k -> Either TargetProblem k
+  -> AvailableTarget k -> Either TargetProblem' k
 selectComponentTarget subtarget =
     either (Left . commonTargetProblem) Right
   . selectComponentTargetBasic subtarget
 
-reportBuildTargetProblems :: Verbosity -> [TargetProblem] -> IO a
+reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
 reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems
 
 reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a

cabal-install/Distribution/Client/CmdRepl.hs

@@ -26,8 +26,13 @@ import qualified Distribution.Types.Lens as L
 import Distribution.Client.NixStyleOptions
          ( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.CmdErrorMessages
+         ( renderTargetSelector, showTargetSelector,
+           renderTargetProblemCommon, renderTargetProblemNoneEnabled,
+           renderTargetProblemNoTargets, targetSelectorRefersToPkgs,
+           renderComponentKind, renderListCommaAnd, renderListSemiAnd,
+           componentKind, sortGroupOn, Plural(..) )
 import Distribution.Client.TargetProblem
-         ( ExtensibleTargetProblem (..), commonTargetProblem
+         ( TargetProblem(..), commonTargetProblem, customTargetProblem
          , noneEnabledTargetProblem, noTargetsProblem )
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.ProjectBuilding
@@ -546,31 +551,30 @@ data ReplProblem
 -- | The various error conditions that can occur when matching a
 -- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.
 --
-type ReplTargetProblem = ExtensibleTargetProblem ReplProblem
+type ReplTargetProblem = TargetProblem ReplProblem
 
 matchesMultipleProblem
   :: TargetSelector
   -> [AvailableTarget ()]
   -> ReplTargetProblem
 matchesMultipleProblem targetSelector targetsExesBuildable =
-  ExtensibleTargetProblemCustomProblem $
-    TargetProblemMatchesMultiple targetSelector targetsExesBuildable
+  customTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable
 
 multipleTargetsProblem
   :: TargetsMap
   -> ReplTargetProblem
-multipleTargetsProblem = ExtensibleTargetProblemCustomProblem . TargetProblemMultipleTargets
+multipleTargetsProblem = customTargetProblem . TargetProblemMultipleTargets
 
-reportTargetProblems :: Verbosity -> [ExtensibleTargetProblem ReplProblem] -> IO a
+reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a
 reportTargetProblems verbosity =
     die' verbosity . unlines . map renderTargetProblem
 
-renderTargetProblem :: ExtensibleTargetProblem ReplProblem -> String
-renderTargetProblem (ExtensibleTargetProblemCommon problem) =
+renderTargetProblem :: TargetProblem ReplProblem -> String
+renderTargetProblem (CommonProblem problem) =
     renderTargetProblemCommon "open a repl for" problem
 
 renderTargetProblem
-  (ExtensibleTargetProblemCustomProblem (TargetProblemMatchesMultiple targetSelector targets)) =
+  (CustomProblem (TargetProblemMatchesMultiple targetSelector targets)) =
     "Cannot open a repl for multiple components at once. The target '"
  ++ showTargetSelector targetSelector ++ "' refers to "
  ++ renderTargetSelector targetSelector ++ " which "
@@ -591,18 +595,18 @@ renderTargetProblem
                                  . availableTargetComponentName
 
 renderTargetProblem
-  (ExtensibleTargetProblemCustomProblem (TargetProblemMultipleTargets selectorMap)) =
+  (CustomProblem (TargetProblemMultipleTargets selectorMap)) =
     "Cannot open a repl for multiple components at once. The targets "
  ++ renderListCommaAnd
       [ "'" ++ showTargetSelector ts ++ "'"
       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]
  ++ " refer to different components."
  ++ ".\n\n" ++ explanationSingleComponentLimitation
 
-renderTargetProblem (ExtensibleTargetProblemNoneEnabled targetSelector targets) =
+renderTargetProblem (NoneEnabled targetSelector targets) =
     renderTargetProblemNoneEnabled "open a repl for" targetSelector targets
 
-renderTargetProblem (ExtensibleTargetProblemNoTargets targetSelector) =
+renderTargetProblem (NoTargets targetSelector) =
     renderTargetProblemNoTargets "open a repl for" targetSelector