diff --git a/cabal-install/Distribution/Solver/Modular.hs b/cabal-install/Distribution/Solver/Modular.hs index 76c44f772d1..8a626149ff9 100644 --- a/cabal-install/Distribution/Solver/Modular.hs +++ b/cabal-install/Distribution/Solver/Modular.hs @@ -59,7 +59,7 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns solve' sc cinfo idx pkgConfigDB pprefs gcs pns where -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx -- Constraints have to be converted into a finite map indexed by PN. gcs = M.fromListWith (++) (map pair pcs) where diff --git a/cabal-install/Distribution/Solver/Modular/Index.hs b/cabal-install/Distribution/Solver/Modular/Index.hs index 42ab3b6643e..fdddfc8237a 100644 --- a/cabal-install/Distribution/Solver/Modular/Index.hs +++ b/cabal-install/Distribution/Solver/Modular/Index.hs @@ -1,6 +1,7 @@ module Distribution.Solver.Modular.Index ( Index , PInfo(..) + , IsBuildable(..) , defaultQualifyOptions , mkIndex ) where @@ -21,11 +22,16 @@ type Index = Map PN (Map I PInfo) -- | Info associated with a package instance. -- Currently, dependencies, component names, flags and failure reasons. +-- The component map records whether any components are unbuildable in the +-- current environment (compiler, os, arch, and global flag constraints). -- Packages that have a failure reason recorded for them are disabled -- 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) [ExposedComponent] FlagInfo (Maybe FailReason) +data PInfo = PInfo (FlaggedDeps PN) (Map ExposedComponent IsBuildable) FlagInfo (Maybe FailReason) + +-- | Whether a component is made unbuildable by a "buildable: False" field. +newtype IsBuildable = IsBuildable Bool 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 4a0f3f4edd1..8d36c9d5d87 100644 --- a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs @@ -30,7 +30,9 @@ import Distribution.Types.ForeignLib import Distribution.Solver.Types.ComponentDeps ( Component(..), componentNameToComponent ) import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage @@ -53,10 +55,13 @@ import Distribution.Solver.Modular.Version -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables -> - SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index -convPIs os arch comp sip strfl solveExes iidx sidx = - mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl solveExes sidx) +convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> ShadowPkgs -> StrongFlags -> SolveExecutables + -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) + -> Index +convPIs os arch comp constraints sip strfl solveExes iidx sidx = + mkIndex $ + convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. @@ -87,8 +92,10 @@ convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of - Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken)) - Just fds -> (pn, i, PInfo fds [ExposedLib] M.empty Nothing) + Nothing -> (pn, i, PInfo [] M.empty M.empty (Just Broken)) + Just fds -> ( pn + , i + , PInfo fds (M.singleton ExposedLib (IsBuildable True)) M.empty Nothing) where (pn, i) = convId ipi -- 'sourceLibName' is unreliable, but for now we only really use this for @@ -140,24 +147,29 @@ convIPId dr comp idx ipid = -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> - CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo strfl solveExes = L.map (convSP os arch cinfo strfl solveExes) . CI.allPackages +convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables + -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] +convSPI' os arch cinfo constraints strfl solveExes = + L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = +convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) +convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo - in (pn, i, convGPD os arch cinfo strfl solveExes pn gpd) + pkgConstraints = fromMaybe [] $ M.lookup pn constraints + in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we -- want to keep the condition tree, but simplify much of the test. -- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> - PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo strfl solveExes pn +convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription + -> PInfo +convGPD os arch cinfo constraints strfl solveExes pn (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags @@ -223,8 +235,81 @@ convGPD os arch cinfo strfl solveExes pn -- forced to, emit a meaningful solver error message). fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer) | otherwise = Nothing - in - PInfo flagged_deps (L.map (ExposedExe . fst) exes ++ [ExposedLib | isJust mlib]) fds fr + + components :: Map ExposedComponent IsBuildable + components = M.fromList $ libComps ++ exeComps + where + libComps = [ (ExposedLib, IsBuildable $ isBuildable libBuildInfo lib) + | lib <- maybeToList mlib ] + exeComps = [ (ExposedExe name, IsBuildable $ isBuildable buildInfo exe) + | (name, exe) <- exes ] + isBuildable = isBuildableComponent os arch cinfo constraints + + 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 + where + flagAssignment :: [(FlagName, Bool)] + flagAssignment = + mconcat [ unFlagAssignment fa + | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) + <- L.map unlabelPackageConstraint constraints] + + -- Simplify the condition, using the current environment. Most of this + -- function was copied from convBranch and + -- Distribution.Types.Condition.simplifyCondition. + simplifyCondition :: Condition ConfVar -> Condition ConfVar + simplifyCondition (Var (OS os')) = Lit (os == os') + simplifyCondition (Var (Arch arch')) = Lit (arch == arch') + simplifyCondition (Var (Impl cf cvr)) + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True + | otherwise = Lit False + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + simplifyCondition (Var (Flag f)) + | Just b <- L.lookup f flagAssignment = Lit b + simplifyCondition (Var v) = Var v + simplifyCondition (Lit b) = Lit b + simplifyCondition (CNot c) = + case simplifyCondition c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + simplifyCondition (COr c d) = + case (simplifyCondition c, simplifyCondition d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c', d') -> COr c' d' + simplifyCondition (CAnd c d) = + case (simplifyCondition c, simplifyCondition d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c', d') -> CAnd c' d' -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs index 494d6897970..1c08c400ca2 100644 --- a/cabal-install/Distribution/Solver/Modular/Message.hs +++ b/cabal-install/Distribution/Solver/Modular/Message.hs @@ -110,7 +110,9 @@ 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 _ (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 _ (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)" showFR _ Shadowed = " (shadowed by another installed package with same version)" diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs index b7c03541a0c..d7288e9b6be 100644 --- a/cabal-install/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install/Distribution/Solver/Modular/Tree.hs @@ -101,7 +101,9 @@ data FailReason = UnsupportedExtension Extension | NewPackageDoesNotMatchExistingConstraint ConflictingDep | ConflictingConstraints ConflictingDep ConflictingDep | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) | PackageRequiresMissingComponent QPN ExposedComponent + | PackageRequiresUnbuildableComponent QPN ExposedComponent | CannotInstall | CannotReinstall | Shadowed diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs index f3d185fd1b8..75e7782d159 100644 --- a/cabal-install/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install/Distribution/Solver/Modular/Validate.hs @@ -108,8 +108,8 @@ data ValidateState = VS { pa :: PreAssignment, -- Map from package name to the components that are provided by the chosen - -- instance of that package. - availableComponents :: Map QPN [ExposedComponent], + -- instance of that package, and whether those components are buildable. + availableComponents :: Map QPN (Map ExposedComponent IsBuildable), -- Map from package name to the components that are required from that -- package. @@ -226,7 +226,7 @@ validate = cata go newDeps = do nppa <- mnppa rComps' <- extendRequiredComponents aComps rComps newactives - checkComponentsInNewPackage rComps qpn comps + checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps return (nppa, rComps') in case newDeps of Left (c, fr) -> -- We have an inconsistency. We can stop. @@ -299,17 +299,31 @@ 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. -checkComponentsInNewPackage :: Map QPN ComponentDependencyReasons +-- are required from that package so far. The components must also be buildable. +checkComponentsInNewPackage :: ComponentDependencyReasons -> QPN - -> [ExposedComponent] + -> Map ExposedComponent IsBuildable -> Either Conflict () checkComponentsInNewPackage required qpn providedComps = - case M.toList $ deleteKeys providedComps (M.findWithDefault M.empty qpn required) of - (missingComp, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr - in Left (cs, NewPackageIsMissingRequiredComponent missingComp dr) - [] -> Right () + 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 () where + mkConflict :: ExposedComponent + -> DependencyReason QPN + -> (ExposedComponent -> DependencyReason QPN -> FailReason) + -> Conflict + mkConflict comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToCS 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 @@ -466,9 +480,9 @@ merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Const -- | 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 from one of the previously chosen +-- requires a component that is missing or unbuildable in a previously chosen -- packages. -extendRequiredComponents :: Map QPN [ExposedComponent] +extendRequiredComponents :: Map QPN (Map ExposedComponent IsBuildable) -> Map QPN ComponentDependencyReasons -> [LDep QPN] -> Either Conflict (Map QPN ComponentDependencyReasons) @@ -483,11 +497,26 @@ extendRequiredComponents available = foldM extendSingle -- already been chosen. case M.lookup qpn available of Just comps - | L.notElem comp comps -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr) - in Left (cs, PackageRequiresMissingComponent qpn comp) - _ -> Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required + | 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 extendSingle required _ = Right required + mkConflict :: QPN + -> ExposedComponent + -> DependencyReason QPN + -> (QPN -> ExposedComponent -> FailReason) + -> Conflict + mkConflict qpn comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToCS 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 validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index ea13db07201..d1a30870ea4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -348,6 +348,48 @@ tests = [ , testGroup "internal dependencies" [ runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) ] + -- tests for partial fix for issue #5325 + , testGroup "Components that are unbuildable in the current environment" $ + let flagConstraint = ExFlagConstraint . ScopeAnyQualifier + in [ + let db = [ Right $ exAv "A" 1 [ExFlagged "build-lib" (Buildable []) NotBuildable] ] + in runTest $ constraints [flagConstraint "A" "build-lib" False] $ + mkTest db "install unbuildable library" ["A"] $ + solverSuccess [("A", 1)] + + , let db = [ Right $ exAvNoLibrary "A" 1 + `withExe` ExExe "exe" [ExFlagged "build-exe" (Buildable []) NotBuildable] ] + in runTest $ constraints [flagConstraint "A" "build-exe" False] $ + mkTest db "install unbuildable exe" ["A"] $ + solverSuccess [("A", 1)] + + , let db = [ Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [ExFlagged "build-lib" (Buildable []) NotBuildable] ] + in runTest $ constraints [flagConstraint "B" "build-lib" False] $ + mkTest db "reject library dependency with unbuildable library" ["A"] $ + solverFailure $ isInfixOf $ + "rejecting: B-1.0.0 (library is not buildable in the " + ++ "current environment, but it is required by A)" + + , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"] + , Right $ exAv "B" 1 [ExFlagged "build-lib" (Buildable []) NotBuildable] + `withExe` ExExe "bt" [] ] + in runTest $ constraints [flagConstraint "B" "build-lib" False] $ + mkTest db "allow build-tool dependency with unbuildable library" ["A"] $ + solverSuccess [("A", 1), ("B", 1)] + + , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"] + , Right $ exAv "B" 1 [] + `withExe` ExExe "bt" [ExFlagged "build-exe" (Buildable []) NotBuildable] ] + in runTest $ constraints [flagConstraint "B" "build-exe" False] $ + mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $ + solverFailure $ isInfixOf $ + "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not " + ++ "buildable in the current environment, but it is required by A)" + , runTest $ + chooseUnbuildableExeAfterBuildToolsPackage + "choose unbuildable exe after choosing its package" + ] -- Tests for the contents of the solver's log , testGroup "Solver log" [ -- See issue #3203. The solver should only choose a version for A once. @@ -1534,6 +1576,36 @@ requireConsistentBuildToolVersions name = exes = [ExExe "exe1" [], ExExe "exe2" []] +-- | This test is similar to the failure case for +-- chooseExeAfterBuildToolsPackage, except that the build tool is unbuildable +-- instead of missing. +chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest +chooseUnbuildableExeAfterBuildToolsPackage name = + constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $ + goalOrder goals $ + mkTest db name ["A"] $ solverFailure $ isInfixOf $ + "rejecting: A:+use-bt2 (requires executable 'bt2' from A:B:exe.B, but " + ++ "the component is not buildable in the current environment)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ ExBuildToolAny "B" "bt1" + , exFlagged "use-bt2" [ExBuildToolAny "B" "bt2"] + [ExAny "unknown"]] + , Right $ exAvNoLibrary "B" 1 + `withExes` + [ ExExe "bt1" [] + , ExExe "bt2" [ExFlagged "build-bt2" (Buildable []) NotBuildable] + ] + ] + + goals :: [ExampleVar] + goals = [ + P QualNone "A" + , P (QualExe "A" "B") "B" + , F QualNone "A" "use-bt2" + ] + {------------------------------------------------------------------------------- Databases for legacy build-tools -------------------------------------------------------------------------------} diff --git a/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out b/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out index 5aa2db6bdb7..7f5ee674bd8 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out +++ b/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out @@ -1,6 +1,8 @@ # cabal new-build Resolving dependencies... -Error: - Dependency on unbuildable library from p - In the stanza 'library' - In the inplace package 'q-1.0' +cabal: Could not resolve dependencies: +[__0] trying: p-1.0 (user goal) +[__1] next goal: q (user goal) +[__1] rejecting: q-1.0 (requires library from p, but the component is not buildable in the current environment) +[__1] fail (backjumping, conflict set: p, q) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: p (2), q (2)