diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs index 5c9a8d194b5..59db52aa5d4 100644 --- a/cabal-install/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install/Distribution/Solver/Modular/Builder.hs @@ -172,7 +172,7 @@ addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr -- and furthermore we update the set of goals. -- -- TODO: We could inline this above. -addChildren bs@(BS { next = Instance qpn (PInfo fdeps fdefs _) }) = +addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = addChildren ((scopedExtendOpen qpn fdeps fdefs bs) { next = Goals }) diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs index a8039f4dd65..68120d78d6c 100644 --- a/cabal-install/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install/Distribution/Solver/Modular/Dependency.hs @@ -16,7 +16,6 @@ module Distribution.Solver.Modular.Dependency ( , FlaggedDep(..) , LDep(..) , Dep(..) - , IsExe(..) , DependencyReason(..) , showDependencyReason , flattenFlaggedDeps @@ -49,6 +48,7 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath +import Distribution.Types.UnqualComponentName {------------------------------------------------------------------------------- Constrained instances @@ -99,10 +99,6 @@ flattenFlaggedDeps = concatMap aux type TrueFlaggedDeps qpn = FlaggedDeps qpn type FalseFlaggedDeps qpn = FlaggedDeps qpn --- | Is this dependency on an executable -newtype IsExe = IsExe Bool - deriving (Eq, Show) - -- | A 'Dep' labeled with the reason it was introduced. -- -- 'LDep' intentionally has no 'Functor' instance because the type variable @@ -114,10 +110,10 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as -- dependencies on language extensions. -data Dep qpn = Dep IsExe qpn CI -- ^ dependency on a package (possibly for executable) - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package +data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI -- ^ dependency on a package (possibly for executable) + | Ext Extension -- ^ dependency on a language extension + | Lang Language -- ^ dependency on a language version + | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package deriving Functor -- | The reason that a dependency is active. It identifies the package and any @@ -170,7 +166,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 False "A" (Constrained AnyVersion)) + -- > LDep (DependencyReason "B") (Dep Nothing "A" (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 @@ -182,13 +178,11 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go goD (Ext ext) _ = Ext ext goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep is_exe dep ci) comp - | isExeToBool is_exe = Dep is_exe (Q (PackagePath ns (QualExe pn dep)) dep) ci - | qBase dep = Dep is_exe (Q (PackagePath ns (QualBase pn)) dep) ci - | qSetup comp = Dep is_exe (Q (PackagePath ns (QualSetup pn)) dep) ci - | otherwise = Dep is_exe (Q (PackagePath ns inheritedQ) dep) ci - - isExeToBool (IsExe b) = b + goD (Dep mExe dep ci) comp + | isJust mExe = Dep mExe (Q (PackagePath ns (QualExe pn dep)) dep) ci + | qBase dep = Dep mExe (Q (PackagePath ns (QualBase pn )) dep) ci + | qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn )) dep) ci + | otherwise = Dep mExe (Q (PackagePath ns inheritedQ ) dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup diff --git a/cabal-install/Distribution/Solver/Modular/Index.hs b/cabal-install/Distribution/Solver/Modular/Index.hs index 3ffa3df9927..dda4bf75845 100644 --- a/cabal-install/Distribution/Solver/Modular/Index.hs +++ b/cabal-install/Distribution/Solver/Modular/Index.hs @@ -13,6 +13,7 @@ import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree +import Distribution.Types.UnqualComponentName -- | An index contains information about package instances. This is a nested -- dictionary. Package names are mapped to instances, which in turn is mapped @@ -20,12 +21,12 @@ import Distribution.Solver.Modular.Tree type Index = Map PN (Map I PInfo) -- | Info associated with a package instance. --- Currently, dependencies, flags and failure reasons. +-- Currently, dependencies, executable names, flags and failure reasons. -- 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) FlagInfo (Maybe FailReason) +data PInfo = PInfo (FlaggedDeps PN) [UnqualComponentName] FlagInfo (Maybe FailReason) mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) @@ -39,7 +40,7 @@ defaultQualifyOptions idx = QO { | -- Find all versions of base .. Just is <- [M.lookup base idx] -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is + , (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. , (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps ] diff --git a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs index 96b4bf9d3f5..413c62ee51d 100644 --- a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs @@ -70,8 +70,8 @@ convIPI' (ShadowPkgs sip) idx = where -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed)) - shadow x = x + shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed)) + shadow x = x -- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I. convId :: InstalledPackageInfo -> (PN, I) @@ -84,8 +84,8 @@ convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = case mapM (convIPId (DependencyReason pn [] []) comp idx) (IPI.depends ipi) of - Nothing -> (pn, i, PInfo [] M.empty (Just Broken)) - Just fds -> (pn, i, PInfo fds M.empty Nothing) + Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken)) + Just fds -> (pn, i, PInfo fds [] M.empty Nothing) where (pn, i) = convId ipi -- 'sourceLibName' is unreliable, but for now we only really use this for @@ -131,7 +131,7 @@ 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 (IsExe False) pn (Fixed i))) comp) + in Just (D.Simple (LDep dr (Dep Nothing pn (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable @@ -192,7 +192,7 @@ convGPD os arch cinfo strfl solveExes pn addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (s : ss) in - PInfo flagged_deps fds Nothing + PInfo flagged_deps (L.map fst exes) fds Nothing -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be @@ -367,12 +367,11 @@ convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c -- | 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 (IsExe False) pn (Constrained vr) +convLibDep dr (Dependency pn vr) = LDep dr $ Dep Nothing pn (Constrained vr) --- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency. --- TODO do something about the name of the exe component itself +-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN -convExeDep dr (ExeDependency pn _ vr) = LDep dr $ Dep (IsExe True) pn (Constrained vr) +convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr) -- | Convert setup dependencies convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN diff --git a/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal-install/Distribution/Solver/Modular/Linking.hs index a8da2d1ce67..4051a996e10 100644 --- a/cabal-install/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install/Distribution/Solver/Modular/Linking.hs @@ -97,9 +97,9 @@ validateLinking index = (`runReader` initVS) . cata go goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask - let PInfo deps _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps - newSaved = M.insert qpn qdeps (vsSaved vs) + let PInfo deps _ _ _ = vsIndex vs ! pn ! i + qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) Right vs' -> local (const vs' { vsSaved = newSaved }) r @@ -346,7 +346,7 @@ verifyLinkGroup lg = -- if a constructor is added to the datatype we won't notice it here Just i -> do vs <- get - let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i + let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i flags = M.keys finfo stanzas = [TestStanzas, BenchStanzas] forM_ flags $ \fn -> do diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs index 7a7747e4a34..1c307d5683c 100644 --- a/cabal-install/Distribution/Solver/Modular/Message.hs +++ b/cabal-install/Distribution/Solver/Modular/Message.hs @@ -19,6 +19,7 @@ import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress +import Distribution.Types.UnqualComponentName data Message = Enter -- ^ increase indentation level @@ -154,11 +155,13 @@ constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src showConflictingDep :: ConflictingDep -> String -showConflictingDep (ConflictingDep dr (IsExe is_exe) qpn (Fixed i) ) = +showConflictingDep (ConflictingDep dr mExe qpn ci) = let DependencyReason qpn' _ _ = dr - in (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ - showQPN qpn ++ - (if is_exe then " (exe) " else "") ++ "==" ++ showI i -showConflictingDep (ConflictingDep dr (IsExe is_exe) qpn (Constrained vr)) = - showDependencyReason dr ++ " => " ++ showQPN qpn ++ - (if is_exe then " (exe) " else "") ++ showVR vr + exeStr = case mExe of + Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + Nothing -> "" + in case ci of + Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ + showQPN qpn ++ exeStr ++ "==" ++ showI i + Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ + exeStr ++ showVR vr diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs index 1d6de5f47a1..e654f5e453f 100644 --- a/cabal-install/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install/Distribution/Solver/Modular/Tree.hs @@ -30,6 +30,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath +import Distribution.Types.UnqualComponentName import Language.Haskell.Extension (Extension, Language) type Weight = Double @@ -118,7 +119,7 @@ data FailReason = UnsupportedExtension Extension deriving (Eq, Show) -- | Information about a dependency involved in a conflict, for error messages. -data ConflictingDep = ConflictingDep (DependencyReason QPN) IsExe QPN CI +data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI deriving (Eq, Show) -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs index 331e30336b6..76dd6a988b0 100644 --- a/cabal-install/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install/Distribution/Solver/Modular/Validate.hs @@ -37,6 +37,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) +import Distribution.Types.UnqualComponentName #ifdef DEBUG_CONFLICT_SETS import GHC.Stack (CallStack) @@ -124,7 +125,7 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment type PPreAssignment = Map QPN MergedPkgDep -- | A dependency on a package, including its DependencyReason. -data PkgDep = PkgDep (DependencyReason QPN) IsExe QPN CI +data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI -- | MergedPkgDep records constraints about the instances that can still be -- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a @@ -132,8 +133,8 @@ data PkgDep = PkgDep (DependencyReason QPN) IsExe QPN CI -- them. It also records whether a package is a build-tool dependency, for use -- in log messages. data MergedPkgDep = - MergedDepFixed IsExe (DependencyReason QPN) I - | MergedDepConstrained IsExe [VROrigin] + MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I + | MergedDepConstrained (Maybe UnqualComponentName) [VROrigin] -- | Version ranges paired with origins. type VROrigin = (VR, DependencyReason QPN) @@ -185,7 +186,7 @@ validate = cata go svd <- asks saved -- obtain saved dependencies qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice - let (PInfo deps _ mfr) = idx ! pn ! i + let (PInfo deps _ _ mfr) = idx ! pn ! i -- qualify the deps in the current scope let qdeps = qualifyDeps qo qpn deps -- the new active constraints are given by the instance we have chosen, @@ -328,9 +329,9 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle extendSingle a (LDep dr (Pkg pn vr)) = if pkgPresent pn vr then Right a else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr) - extendSingle a (LDep dr (Dep is_exe qpn ci)) = - let mergedDep = M.findWithDefault (MergedDepConstrained (IsExe False) []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr is_exe qpn ci) of + extendSingle a (LDep dr (Dep mExe qpn ci)) = + let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') Right x -> Right x @@ -340,8 +341,8 @@ extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either (ConflictSet, FailReason) PPreAssignment extendWithPackageChoice (PI qpn i) ppa = - let mergedDep = M.findWithDefault (MergedDepConstrained (IsExe False) []) qpn ppa - newChoice = PkgDep (DependencyReason qpn [] []) (IsExe False) qpn (Fixed i) + let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn ppa + newChoice = PkgDep (DependencyReason qpn [] []) Nothing qpn (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. @@ -370,46 +371,49 @@ merge :: (?loc :: CallStack) => #endif MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep -merge (MergedDepFixed is_exe1 vs1 i1) (PkgDep vs2 is_exe2 p ci@(Fixed i2)) - | i1 == i2 = Right $ MergedDepFixed (mergeIsExe is_exe1 is_exe2) vs1 i1 +merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2)) + | i1 == i2 = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i1 | otherwise = Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 - , ( ConflictingDep vs1 is_exe1 p (Fixed i1) - , ConflictingDep vs2 is_exe2 p ci ) ) + , ( ConflictingDep vs1 mExe1 p (Fixed i1) + , ConflictingDep vs2 mExe2 p ci ) ) -merge (MergedDepFixed is_exe1 vs1 i@(I v _)) (PkgDep vs2 is_exe2 p ci@(Constrained vr)) - | checkVR vr v = Right $ MergedDepFixed (mergeIsExe is_exe1 is_exe2) vs1 i +merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr)) + | checkVR vr v = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i | otherwise = Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 - , ( ConflictingDep vs1 is_exe1 p (Fixed i) - , ConflictingDep vs2 is_exe2 p ci ) ) + , ( ConflictingDep vs1 mExe1 p (Fixed i) + , ConflictingDep vs2 mExe2 p ci ) ) -merge (MergedDepConstrained is_exe1 vrOrigins) (PkgDep vs2 is_exe2 p ci@(Fixed i@(I v _))) = +merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) = go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... where go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep - go [] = Right (MergedDepFixed (mergeIsExe is_exe1 is_exe2) vs2 i) + go [] = Right (MergedDepFixed (mergeExes mExe1 mExe2) vs2 i) go ((vr, vs1) : vros) | checkVR vr v = go vros | otherwise = Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 - , ( ConflictingDep vs1 is_exe1 p (Constrained vr) - , ConflictingDep vs2 is_exe2 p ci ) ) + , ( ConflictingDep vs1 mExe1 p (Constrained vr) + , ConflictingDep vs2 mExe2 p ci ) ) -merge (MergedDepConstrained is_exe1 vrOrigins) (PkgDep vs2 is_exe2 _ (Constrained vr)) = - Right (MergedDepConstrained (mergeIsExe is_exe1 is_exe2) $ +merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) = + Right (MergedDepConstrained (mergeExes mExe1 mExe2) $ -- TODO: This line appends the new version range, to preserve the order used -- before a refactoring. Consider prepending the version range, if there is -- no negative performance impact. vrOrigins ++ [(vr, vs2)]) --- TODO: This function isn't correct, because cabal may need to build both libs --- and exes for a package. The merged value is only used to determine whether to --- print "(exe)" next to conflicts in log message, though. It should be removed --- when component-based solving is implemented. -mergeIsExe :: IsExe -> IsExe -> IsExe -mergeIsExe (IsExe ie1) (IsExe ie2) = IsExe (ie1 || ie2) +-- TODO: This function isn't correct, because cabal may need to build libs +-- and/or multiple exes for a package. The merged value is only used to +-- determine whether to print the name of an exe next to conflicts in log +-- message, though. It should be removed when component-based solving is +-- implemented. +mergeExes :: Maybe UnqualComponentName + -> Maybe UnqualComponentName + -> Maybe UnqualComponentName +mergeExes = (<|>) -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c