diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs index 8fc55f5724d..6b2fdba447b 100644 --- a/cabal-install/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install/Distribution/Solver/Modular/Dependency.hs @@ -55,6 +55,7 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath +import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnqualComponentName @@ -131,7 +132,9 @@ data PkgComponent qpn = PkgComponent qpn ExposedComponent -- | A component that can be depended upon by another package, i.e., a library -- or an executable. -data ExposedComponent = ExposedLib | ExposedExe UnqualComponentName +data ExposedComponent = + ExposedLib LibraryName + | ExposedExe UnqualComponentName deriving (Eq, Ord, Show) -- | The reason that a dependency is active. It identifies the package and any @@ -185,7 +188,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go -- Suppose package B has a setup dependency on package A. -- This will be recorded as something like -- - -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" ExposedLib) (Constrained AnyVersion)) + -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion)) -- -- Observe that when we qualify this dependency, we need to turn that -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier @@ -199,7 +202,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go goD (Pkg pkn vr) _ = Pkg pkn vr goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci - goD (Dep dep@(PkgComponent qpn ExposedLib) ci) comp + goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci diff --git a/cabal-install/Distribution/Solver/Modular/Index.hs b/cabal-install/Distribution/Solver/Modular/Index.hs index ac60fec7d65..c1a8c0be412 100644 --- a/cabal-install/Distribution/Solver/Modular/Index.hs +++ b/cabal-install/Distribution/Solver/Modular/Index.hs @@ -1,6 +1,8 @@ module Distribution.Solver.Modular.Index ( Index , PInfo(..) + , ComponentInfo(..) + , IsVisible(..) , IsBuildable(..) , defaultQualifyOptions , mkIndex @@ -30,10 +32,24 @@ type Index = Map PN (Map I PInfo) -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) (Map ExposedComponent IsBuildable) FlagInfo (Maybe FailReason) +data PInfo = PInfo (FlaggedDeps PN) + (Map ExposedComponent ComponentInfo) + FlagInfo + (Maybe FailReason) + +-- | Info associated with each library and executable in a package instance. +data ComponentInfo = ComponentInfo { + compIsVisible :: IsVisible + , compIsBuildable :: IsBuildable + } + +-- | Whether a component is visible in the current environment. +newtype IsVisible = IsVisible Bool + deriving Eq -- | Whether a component is made unbuildable by a "buildable: False" field. newtype IsBuildable = IsBuildable Bool + deriving Eq mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) diff --git a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs index f48144c15b3..981281d9f23 100644 --- a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs @@ -25,6 +25,7 @@ import Distribution.PackageDescription.Configuration import qualified Distribution.Simple.PackageIndex as SI import Distribution.System import Distribution.Types.ForeignLib +import Distribution.Types.LibraryVisibility import Distribution.Solver.Types.ComponentDeps ( Component(..), componentNameToComponent ) @@ -92,11 +93,18 @@ convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of Nothing -> (pn, i, PInfo [] M.empty M.empty (Just Broken)) - Just fds -> ( pn - , i - , PInfo fds (M.singleton ExposedLib (IsBuildable True)) M.empty Nothing) + Just fds -> ( pn, i, PInfo fds components M.empty Nothing) where + -- TODO: Handle sub-libraries and visibility. + components = + M.singleton (ExposedLib LMainLibName) + ComponentInfo { + compIsVisible = IsVisible True + , compIsBuildable = IsBuildable True + } + (pn, i) = convId ipi + -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi @@ -140,7 +148,8 @@ convIPId dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Nothing Just ipi -> let (pn, i) = convId ipi - in Just (D.Simple (LDep dr (Dep (PkgComponent pn ExposedLib) (Fixed i))) comp) + name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. + in Just (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable @@ -213,34 +222,52 @@ convGPD os arch cinfo constraints strfl solveExes pn Just ver -> Just (UnsupportedSpecVer ver) Nothing -> Nothing - components :: Map ExposedComponent IsBuildable - components = M.fromList $ libComps ++ exeComps + components :: Map ExposedComponent ComponentInfo + components = M.fromList $ libComps ++ subLibComps ++ exeComps where - libComps = [ (ExposedLib, IsBuildable $ isBuildable libBuildInfo lib) + libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib) | lib <- maybeToList mlib ] - exeComps = [ (ExposedExe name, IsBuildable $ isBuildable buildInfo exe) + subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib) + | (name, lib) <- sub_libs ] + exeComps = [ ( ExposedExe name + , ComponentInfo { + compIsVisible = IsVisible True + , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False + } + ) | (name, exe) <- exes ] - isBuildable = isBuildableComponent os arch cinfo constraints + + libToComponentInfo lib = + ComponentInfo { + compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True + , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False + } + + testCondition = testConditionForComponent os arch cinfo constraints + + isPrivate LibraryVisibilityPrivate = True + isPrivate LibraryVisibilityPublic = False in PInfo flagged_deps components fds fr --- | Returns true if the component is buildable in the given environment. --- This function can give false-positives. For example, it only considers flags --- that are set by unqualified flag constraints, and it doesn't check whether --- the intra-package dependencies of a component are buildable. It is also --- possible for the solver to later assign a value to an automatic flag that --- makes the component unbuildable. -isBuildableComponent :: OS - -> Arch - -> CompilerInfo - -> [LabeledPackageConstraint] - -> (a -> BuildInfo) - -> CondTree ConfVar [Dependency] a - -> Bool -isBuildableComponent os arch cinfo constraints getInfo tree = - case simplifyCondition $ extractCondition (buildable . getInfo) tree of - Lit False -> False - _ -> True +-- | Applies the given predicate (for example, testing buildability or +-- visibility) to the given component and environment. Values are combined with +-- AND. This function returns 'Nothing' when the result cannot be determined +-- before dependency solving. Additionally, this function only considers flags +-- that are set by unqualified flag constraints, and it doesn't check the +-- intra-package dependencies of a component. +testConditionForComponent :: OS + -> Arch + -> CompilerInfo + -> [LabeledPackageConstraint] + -> (a -> Bool) + -> CondTree ConfVar [Dependency] a + -> Maybe Bool +testConditionForComponent os arch cinfo constraints p tree = + case simplifyCondition $ extractCondition p tree of + Lit True -> Just True + Lit False -> Just False + _ -> Nothing where flagAssignment :: [(FlagName, Bool)] flagAssignment = @@ -332,8 +359,10 @@ convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(Solv -- duplicates could grow exponentially from the leaves to the root -- of the tree. mergeSimpleDeps $ - L.map (\d -> D.Simple (convLibDep dr d) comp) - (mapMaybe (filterIPNs ipns) ds) -- unconditional package dependencies + [ D.Simple singleDep comp + | dep <- mapMaybe (filterIPNs ipns) ds + , singleDep <- convLibDeps dr dep ] -- unconditional package dependencies + ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies @@ -537,9 +566,12 @@ unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) --- | Convert a Cabal dependency on a library to a solver-specific dependency. -convLibDep :: DependencyReason PN -> Dependency -> LDep PN -convLibDep dr (Dependency pn vr _) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr) +-- | Convert a Cabal dependency on a set of library components (from a single +-- package) to solver-specific dependencies. +convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN] +convLibDeps dr (Dependency pn vr libs) = + [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) + | lib <- S.toList libs ] -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN @@ -548,5 +580,6 @@ convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (Expose -- | Convert setup dependencies convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN convSetupBuildInfo pn nfo = - L.map (\d -> D.Simple (convLibDep (DependencyReason pn M.empty S.empty) d) ComponentSetup) - (setupDepends nfo) + [ D.Simple singleDep ComponentSetup + | dep <- setupDepends nfo + , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ] diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs index 5d642d32c14..9624f76e02e 100644 --- a/cabal-install/Distribution/Solver/Modular/Message.hs +++ b/cabal-install/Distribution/Solver/Modular/Message.hs @@ -25,6 +25,7 @@ import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress +import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName data Message = @@ -220,8 +221,10 @@ showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" +showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" +showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)" showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" showFR _ CannotInstall = " (only already installed instances can be used)" showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" @@ -247,8 +250,9 @@ showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" showExposedComponent :: ExposedComponent -> String -showExposedComponent ExposedLib = "library" -showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" +showExposedComponent (ExposedLib LMainLibName) = "library" +showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'" +showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src @@ -257,8 +261,9 @@ showConflictingDep :: ConflictingDep -> String showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = let DependencyReason qpn' _ _ = dr componentStr = case comp of - ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" - ExposedLib -> "" + ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + ExposedLib LMainLibName -> "" + ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" in case ci of Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ showQPN qpn ++ componentStr ++ "==" ++ showI i diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs index e2d7c091031..ca7099278c7 100644 --- a/cabal-install/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install/Distribution/Solver/Modular/Tree.hs @@ -102,8 +102,10 @@ data FailReason = UnsupportedExtension Extension | NewPackageDoesNotMatchExistingConstraint ConflictingDep | ConflictingConstraints ConflictingDep ConflictingDep | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) | PackageRequiresMissingComponent QPN ExposedComponent + | PackageRequiresPrivateComponent QPN ExposedComponent | PackageRequiresUnbuildableComponent QPN ExposedComponent | CannotInstall | CannotReinstall diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs index a3dec6e1f67..0410ffe8a39 100644 --- a/cabal-install/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install/Distribution/Solver/Modular/Validate.hs @@ -14,6 +14,7 @@ module Distribution.Solver.Modular.Validate (validateTree) where import Control.Applicative import Control.Monad.Reader hiding (sequence) +import Data.Either (lefts) import Data.Function (on) import Data.Traversable import Prelude hiding (sequence) @@ -38,6 +39,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) +import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange #ifdef DEBUG_CONFLICT_SETS @@ -110,8 +112,9 @@ data ValidateState = VS { pa :: PreAssignment, -- Map from package name to the components that are provided by the chosen - -- instance of that package, and whether those components are buildable. - availableComponents :: Map QPN (Map ExposedComponent IsBuildable), + -- instance of that package, and whether those components are visible and + -- buildable. + availableComponents :: Map QPN (Map ExposedComponent ComponentInfo), -- Map from package name to the components that are required from that -- package. @@ -301,20 +304,29 @@ validate = cata go local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r -- | Check that a newly chosen package instance contains all components that --- are required from that package so far. The components must also be buildable. +-- are required from that package so far. The components must also be visible +-- and buildable. checkComponentsInNewPackage :: ComponentDependencyReasons -> QPN - -> Map ExposedComponent IsBuildable + -> Map ExposedComponent ComponentInfo -> Either Conflict () checkComponentsInNewPackage required qpn providedComps = case M.toList $ deleteKeys (M.keys providedComps) required of (missingComp, dr) : _ -> Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent [] -> - case M.toList $ deleteKeys buildableProvidedComps required of - (unbuildableComp, dr) : _ -> - Left $ mkConflict unbuildableComp dr NewPackageHasUnbuildableRequiredComponent - [] -> Right () + let failures = lefts + [ case () of + _ | compIsVisible compInfo == IsVisible False -> + Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent + | otherwise -> Right () + | let merged = M.intersectionWith (,) required providedComps + , (comp, (dr, compInfo)) <- M.toList merged ] + in case failures of + failure : _ -> Left failure + [] -> Right () where mkConflict :: ExposedComponent -> DependencyReason QPN @@ -323,9 +335,6 @@ checkComponentsInNewPackage required qpn providedComps = mkConflict comp dr mkFailure = (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) - buildableProvidedComps :: [ExposedComponent] - buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps] - deleteKeys :: Ord k => [k] -> Map k v -> Map k v deleteKeys ks m = L.foldr M.delete m ks @@ -411,13 +420,15 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle -- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. -- -- TODO: The new constraint is implemented as a dependency from foo to foo's --- library. That isn't correct, because foo might only be needed as a build +-- main library. That isn't correct, because foo might only be needed as a build -- tool dependency. The implemention may need to change when we support -- component-based dependency solving. extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment extendWithPackageChoice (PI qpn i) ppa = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa - newChoice = PkgDep (DependencyReason qpn M.empty S.empty) (PkgComponent qpn ExposedLib) (Fixed i) + newChoice = PkgDep (DependencyReason qpn M.empty S.empty) + (PkgComponent qpn (ExposedLib LMainLibName)) + (Fixed i) in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of Left (c, (d, _d')) -> -- Don't include the package choice in the -- FailReason, because it is redundant. @@ -521,9 +532,9 @@ createConflictSetForVersionConflict pkg -- | Takes a list of new dependencies and uses it to try to update the map of -- known component dependencies. It returns a failure when a new dependency --- requires a component that is missing or unbuildable in a previously chosen --- packages. -extendRequiredComponents :: Map QPN (Map ExposedComponent IsBuildable) +-- requires a component that is missing, private, or unbuildable in a previously +-- chosen package. +extendRequiredComponents :: Map QPN (Map ExposedComponent ComponentInfo) -> Map QPN ComponentDependencyReasons -> [LDep QPN] -> Either Conflict (Map QPN ComponentDependencyReasons) @@ -534,16 +545,21 @@ extendRequiredComponents available = foldM extendSingle -> Either Conflict (Map QPN ComponentDependencyReasons) extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = let compDeps = M.findWithDefault M.empty qpn required + success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required in -- Only check for the existence of the component if its package has -- already been chosen. case M.lookup qpn available of - Just comps - | M.notMember comp comps -> - Left $ mkConflict qpn comp dr PackageRequiresMissingComponent - | L.notElem comp (buildableComps comps) -> - Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent - _ -> - Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required + Just comps -> + case M.lookup comp comps of + Nothing -> + Left $ mkConflict qpn comp dr PackageRequiresMissingComponent + Just compInfo + | compIsVisible compInfo == IsVisible False -> + Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent + | otherwise -> success + Nothing -> success extendSingle required _ = Right required mkConflict :: QPN @@ -554,9 +570,6 @@ extendRequiredComponents available = foldM extendSingle mkConflict qpn comp dr mkFailure = (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) - buildableComps :: Map comp IsBuildable -> [comp] - buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps] - -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c