Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Refactor shared TargetProblem data types into their own module. #6821

Merged
merged 1 commit into from
May 19, 2020
Merged

Refactor shared TargetProblem data types into their own module. #6821

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
93 changes: 53 additions & 40 deletions cabal-install/Distribution/Client/CmdBench.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,9 @@ module Distribution.Client.CmdBench (
benchAction,

-- * Internals exposed for testing
TargetProblem(..),
componentNotBenchmarkProblem,
isSubComponentProblem,
noBenchmarksProblem,
selectPackageTargets,
selectComponentTarget
) where
Expand All @@ -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
Expand Down Expand Up @@ -98,7 +104,6 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do
$ resolveTargets
selectPackageTargets
selectComponentTarget
TargetProblemCommon
elaboratedPlan
Nothing
targetSelectors
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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 "
Expand Down
42 changes: 9 additions & 33 deletions cabal-install/Distribution/Client/CmdBuild.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,6 @@ module Distribution.Client.CmdBuild (
buildAction,

-- * Internals exposed for testing
TargetProblem(..),
selectPackageTargets,
selectComponentTarget
) where
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down
60 changes: 44 additions & 16 deletions cabal-install/Distribution/Client/CmdErrorMessages.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,7 @@
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}


-- | Utilities to help format error messages for the various CLI commands.
--
Expand All @@ -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
Expand Down Expand Up @@ -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 "
Expand All @@ -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 "
Expand All @@ -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 "
Expand All @@ -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
Expand All @@ -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 "
Expand Down
Loading