Skip to content

Commit

Permalink
Merge pull request #10273 from 9999years/missing-or-private-details
Browse files Browse the repository at this point in the history
Show why configuring dependencies failed
  • Loading branch information
mergify[bot] authored Oct 1, 2024
2 parents db5628c + ec60185 commit ba507b1
Show file tree
Hide file tree
Showing 29 changed files with 328 additions and 93 deletions.
3 changes: 3 additions & 0 deletions Cabal-syntax/Cabal-syntax.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -135,6 +135,7 @@ library
Distribution.Types.ConfVar
Distribution.Types.Dependency
Distribution.Types.DependencyMap
Distribution.Types.DependencySatisfaction
Distribution.Types.ExeDependency
Distribution.Types.Executable
Distribution.Types.Executable.Lens
Expand All @@ -158,6 +159,8 @@ library
Distribution.Types.Library.Lens
Distribution.Types.LibraryName
Distribution.Types.LibraryVisibility
Distribution.Types.MissingDependency
Distribution.Types.MissingDependencyReason
Distribution.Types.Mixin
Distribution.Types.Module
Distribution.Types.ModuleReexport
Expand Down
4 changes: 4 additions & 0 deletions Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@ module Distribution.Compat.NonEmptySet

-- * Deletion
, delete
, filter

-- * Conversions
, toNonEmpty
Expand Down Expand Up @@ -116,6 +117,9 @@ delete x (NES xs)
where
res = Set.delete x xs

filter :: (a -> Bool) -> NonEmptySet a -> Set.Set a
filter predicate (NES set) = Set.filter predicate set

-------------------------------------------------------------------------------
-- Conversions
-------------------------------------------------------------------------------
Expand Down
62 changes: 24 additions & 38 deletions Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs
Original file line number Diff line number Diff line change
Expand Up @@ -56,12 +56,13 @@ import Distribution.System
import Distribution.Types.Component
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.DependencyMap
import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..))
import Distribution.Types.MissingDependency (MissingDependency (..))
import Distribution.Types.PackageVersionConstraint
import Distribution.Utils.Generic
import Distribution.Utils.Path (sameDirectory)
import Distribution.Version

import qualified Data.Map.Lazy as Map
import Data.Tree (Tree (Node))

------------------------------------------------------------------------------
Expand Down Expand Up @@ -144,15 +145,17 @@ parseCondition = condOr

------------------------------------------------------------------------------

-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
-- | Result of dependency test. Isomorphic to @Maybe@ but renamed for
-- clarity.
data DepTestRslt d = DepOk | MissingDeps d
data DepTestRslt
= DepOk
| MissingDeps [MissingDependency]

instance Semigroup d => Monoid (DepTestRslt d) where
instance Monoid DepTestRslt where
mempty = DepOk
mappend = (<>)

instance Semigroup d => Semigroup (DepTestRslt d) where
instance Semigroup DepTestRslt where
DepOk <> x = x
x <> DepOk = x
(MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')
Expand Down Expand Up @@ -190,13 +193,13 @@ resolveWithFlags
-> [PackageVersionConstraint]
-- ^ Additional constraints
-> [CondTree ConfVar [Dependency] PDTagged]
-> ([Dependency] -> DepTestRslt [Dependency])
-> ([Dependency] -> DepTestRslt)
-- ^ Dependency test function.
-> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
-> Either [MissingDependency] (TargetSet PDTagged, FlagAssignment)
-- ^ Either the missing dependencies (error case), or a pair of
-- (set of build targets with dependencies, chosen flag assignments)
resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
explore (build mempty dom)
where
-- simplify trees by (partially) evaluating all conditions and converting
-- dependencies to dependency maps.
Expand All @@ -216,7 +219,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
-- computation overhead in the successful case.
explore
:: Tree FlagAssignment
-> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)
-> Either [MissingDependency] (TargetSet PDTagged, FlagAssignment)
explore (Node flags ts) =
let targetSet =
TargetSet $
Expand All @@ -229,7 +232,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
DepOk
| null ts -> Right (targetSet, flags)
| otherwise -> tryAll $ map explore ts
MissingDeps mds -> Left (toDepMapUnion mds)
MissingDeps mds -> Left mds

-- Builds a tree of all possible flag assignments. Internal nodes
-- have only partial assignments.
Expand All @@ -238,18 +241,18 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
build assigned ((fn, vals) : unassigned) =
Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals

tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a
tryAll :: Monoid a => [Either a b] -> Either a b
tryAll = foldr mp mz

-- special version of `mplus' for our local purposes
mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a
mp :: Monoid a => Either a b -> Either a b -> Either a b
mp m@(Right _) _ = m
mp _ m@(Right _) = m
mp (Left xs) (Left ys) = Left (xs <> ys)

-- `mzero'
mz :: Either DepMapUnion a
mz = Left (DepMapUnion Map.empty)
mz :: Monoid a => Either a b
mz = Left mempty

env :: FlagAssignment -> FlagName -> Either FlagName Bool
env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags
Expand Down Expand Up @@ -323,27 +326,6 @@ extractConditions f gpkg =
, extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
]

-- | A map of package constraints that combines version ranges using 'unionVersionRanges'.
newtype DepMapUnion = DepMapUnion {unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName)}

instance Semigroup DepMapUnion where
DepMapUnion x <> DepMapUnion y =
DepMapUnion $
Map.unionWith unionVersionRanges' x y

unionVersionRanges'
:: (VersionRange, NonEmptySet LibraryName)
-> (VersionRange, NonEmptySet LibraryName)
-> (VersionRange, NonEmptySet LibraryName)
unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')

toDepMapUnion :: [Dependency] -> DepMapUnion
toDepMapUnion ds =
DepMapUnion $ Map.fromListWith unionVersionRanges' [(p, (vr, cs)) | Dependency p vr cs <- ds]

fromDepMapUnion :: DepMapUnion -> [Dependency]
fromDepMapUnion m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDepMapUnion m)]

freeVars :: CondTree ConfVar c a -> [FlagName]
freeVars t = [f | PackageFlag f <- freeVars' t]
where
Expand Down Expand Up @@ -453,7 +435,7 @@ finalizePD
:: FlagAssignment
-- ^ Explicitly specified flag assignments
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> (Dependency -> DependencySatisfaction)
-- ^ Is a given dependency satisfiable from the set of
-- available packages? If this is unknown then use
-- True.
Expand All @@ -465,7 +447,7 @@ finalizePD
-- ^ Additional constraints
-> GenericPackageDescription
-> Either
[Dependency]
[MissingDependency]
(PackageDescription, FlagAssignment)
-- ^ Either missing dependencies or the resolved package
-- description along with the flag assignments chosen.
Expand Down Expand Up @@ -526,7 +508,11 @@ finalizePD
| otherwise -> [b, not b]
-- flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
check ds =
let missingDeps = filter (not . satisfyDep) ds
let missingDeps =
[ MissingDependency dependency reason
| (dependency, Unsatisfied reason) <-
map (\dependency -> (dependency, satisfyDep dependency)) ds
]
in if null missingDeps
then DepOk
else MissingDeps missingDeps
Expand Down
10 changes: 10 additions & 0 deletions Cabal-syntax/src/Distribution/Pretty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,8 @@ module Distribution.Pretty
, showTokenStr
, showFreeText
, showFreeTextV3
, commaSpaceSep
, commaSep

-- * Deprecated
, Separator
Expand Down Expand Up @@ -118,3 +120,11 @@ lines_ s =
in l : case s' of
[] -> []
(_ : s'') -> lines_ s''

-- | Separate a list of documents by commas and spaces.
commaSpaceSep :: Pretty a => [a] -> PP.Doc
commaSpaceSep = PP.hsep . PP.punctuate PP.comma . map pretty

-- | Separate a list of documents by commas.
commaSep :: Pretty a => [a] -> PP.Doc
commaSep = PP.hcat . PP.punctuate PP.comma . map pretty
16 changes: 3 additions & 13 deletions Cabal-syntax/src/Distribution/Types/Dependency.hs
Original file line number Diff line number Diff line change
Expand Up @@ -78,31 +78,21 @@ instance NFData Dependency where rnf = genericRnf
-- "pkg"
--
-- >>> prettyShow $ Dependency (mkPackageName "pkg") anyVersion $ NES.insert (LSubLibName $ mkUnqualComponentName "sublib") mainLibSet
-- "pkg:{pkg, sublib}"
-- "pkg:{pkg,sublib}"
--
-- >>> prettyShow $ Dependency (mkPackageName "pkg") anyVersion $ NES.singleton (LSubLibName $ mkUnqualComponentName "sublib")
-- "pkg:sublib"
--
-- >>> prettyShow $ Dependency (mkPackageName "pkg") anyVersion $ NES.insert (LSubLibName $ mkUnqualComponentName "sublib-b") $ NES.singleton (LSubLibName $ mkUnqualComponentName "sublib-a")
-- "pkg:{sublib-a, sublib-b}"
-- "pkg:{sublib-a,sublib-b}"
instance Pretty Dependency where
pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver
pretty (Dependency name ver sublibs) = prettyLibraryNames name (NES.toNonEmpty sublibs) <+> pver
where
-- TODO: change to isAnyVersion after #6736
pver
| isAnyVersionLight ver = PP.empty
| otherwise = pretty ver

withSubLibs doc = case NES.toList sublibs of
[LMainLibName] -> doc
[LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq
_ -> doc <<>> PP.colon <<>> PP.braces prettySublibs

prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs

prettySublib LMainLibName = PP.text $ unPackageName name
prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un

-- |
--
-- >>> simpleParsec "mylib:sub" :: Maybe Dependency
Expand Down
14 changes: 14 additions & 0 deletions Cabal-syntax/src/Distribution/Types/DependencySatisfaction.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,14 @@
module Distribution.Types.DependencySatisfaction
( DependencySatisfaction (..)
) where

import Distribution.Types.MissingDependencyReason (MissingDependencyReason)

-- | Whether or not a dependency constraint is satisfied.
data DependencySatisfaction
= -- | The dependency constraint is satisfied.
Satisfied
| -- | The dependency constraint is not satisfied.
--
-- Includes a reason for explanation.
Unsatisfied MissingDependencyReason
18 changes: 18 additions & 0 deletions Cabal-syntax/src/Distribution/Types/LibraryName.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ module Distribution.Types.LibraryName
, libraryNameString

-- * Pretty & Parse
, prettyLibraryNames
, prettyLibraryNameComponent
, parsecLibraryNameComponent
) where
Expand All @@ -21,6 +22,7 @@ import Distribution.Parsec
import Distribution.Pretty
import Distribution.Types.UnqualComponentName

import qualified Data.List.NonEmpty as NEL
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp

Expand All @@ -42,6 +44,22 @@ prettyLibraryNameComponent :: LibraryName -> Disp.Doc
prettyLibraryNameComponent LMainLibName = Disp.text "lib"
prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str

-- | Pretty print a 'LibraryName' after a package name.
--
-- Produces output like @foo@, @foo:bar@, or @foo:{bar,baz}@
prettyLibraryNames :: Pretty a => a -> NonEmpty LibraryName -> Disp.Doc
prettyLibraryNames package libraries =
let doc = pretty package

prettyComponent LMainLibName = pretty package
prettyComponent (LSubLibName component) = Disp.text $ unUnqualComponentName component

prettyComponents = commaSep $ prettyComponent <$> NEL.toList libraries
in case libraries of
LMainLibName :| [] -> doc
LSubLibName component :| [] -> doc <<>> Disp.colon <<>> pretty component
_ -> doc <<>> Disp.colon <<>> Disp.braces prettyComponents

parsecLibraryNameComponent :: CabalParsing m => m LibraryName
parsecLibraryNameComponent = do
_ <- P.string "lib"
Expand Down
34 changes: 34 additions & 0 deletions Cabal-syntax/src/Distribution/Types/MissingDependency.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,34 @@
module Distribution.Types.MissingDependency
( MissingDependency (..)
) where

import Distribution.Compat.Prelude
import Distribution.Pretty
import Distribution.Types.Dependency
( Dependency
, simplifyDependency
)
import Distribution.Types.LibraryName
( prettyLibraryNames
)
import Distribution.Types.MissingDependencyReason
( MissingDependencyReason (..)
)

import qualified Text.PrettyPrint as PP

-- | A missing dependency and information on why it's missing.
data MissingDependency = MissingDependency Dependency MissingDependencyReason
deriving (Show)

instance Pretty MissingDependency where
pretty (MissingDependency dependency reason) =
let prettyReason =
case reason of
MissingLibrary libraries ->
PP.text "missing" <+> prettyLibraryNames PP.empty libraries
MissingPackage -> PP.text "missing"
MissingComponent name -> PP.text "missing component" <+> pretty name
WrongVersion versions ->
PP.text "installed:" <+> commaSpaceSep versions
in pretty (simplifyDependency dependency) <+> PP.parens prettyReason
25 changes: 25 additions & 0 deletions Cabal-syntax/src/Distribution/Types/MissingDependencyReason.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,25 @@
module Distribution.Types.MissingDependencyReason
( MissingDependencyReason (..)
) where

import Data.List.NonEmpty (NonEmpty)
import Distribution.Types.LibraryName (LibraryName)
import Distribution.Types.PackageName (PackageName)
import Distribution.Types.Version (Version)

-- | A reason for a depency failing to solve.
--
-- This helps pinpoint dependencies that are installed with an incorrect
-- version vs. dependencies that are not installed at all.
data MissingDependencyReason
= -- | One or more libraries is missing.
MissingLibrary (NonEmpty LibraryName)
| -- | A package is not installed.
MissingPackage
| -- | A package is installed, but the versions don't match.
--
-- Contains the available versions.
WrongVersion [Version]
| -- | A component is not installed.
MissingComponent PackageName
deriving (Show)
4 changes: 2 additions & 2 deletions Cabal-tests/tests/ParserTests/regressions/issue-5846.format
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ version: 5846
library
default-language: Haskell2010
build-depends:
lib1:{a, b},
lib1:{a,b},
lib2:c,
lib3:d >=1,
lib4:{a, b} >=1
lib4:{a,b} >=1
3 changes: 3 additions & 0 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -248,6 +248,7 @@ library
Distribution.Types.ConfVar,
Distribution.Types.Dependency,
Distribution.Types.DependencyMap,
Distribution.Types.DependencySatisfaction,
Distribution.Types.ExeDependency,
Distribution.Types.Executable,
Distribution.Types.Executable.Lens,
Expand All @@ -271,6 +272,8 @@ library
Distribution.Types.Library.Lens,
Distribution.Types.LibraryName,
Distribution.Types.LibraryVisibility,
Distribution.Types.MissingDependency,
Distribution.Types.MissingDependencyReason,
Distribution.Types.Mixin,
Distribution.Types.Module,
Distribution.Types.ModuleReexport,
Expand Down
Loading

0 comments on commit ba507b1

Please sign in to comment.