diff --git a/Cabal-syntax/src/Distribution/Types/Dependency.hs b/Cabal-syntax/src/Distribution/Types/Dependency.hs index f7a738675ff..841bf9d3f7b 100644 --- a/Cabal-syntax/src/Distribution/Types/Dependency.hs +++ b/Cabal-syntax/src/Distribution/Types/Dependency.hs @@ -68,9 +68,11 @@ instance Parsec PrivateDependency where instance Pretty PrivateDependency where pretty (PrivateDependency alias deps) = PP.hsep [pretty alias, PP.text "with", PP.parens (PP.hsep (PP.punctuate PP.comma (map pretty deps)))] +-- Footgun flattenPrivateDepends :: Dependencies -> [Dependency] flattenPrivateDepends (Dependencies _ priv) = concatMap private_depends priv +-- Footgun allDependencies :: Dependencies -> [Dependency] allDependencies (Dependencies pub priv) = pub ++ concatMap private_depends priv diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 39034538ecd..6442ef81482 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -905,7 +905,6 @@ showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] parsecAliasDependency :: ParsecParser AliasDependency parsecAliasDependency = do pn <- parsec - traceShowM pn _ <- P.char '=' gc <- parsecGivenComponent return $ AliasDependency pn gc diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 19debc2bdf4..91d0e74f26b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -34,23 +34,23 @@ convCP iidx sidx (CP qpi fa es ds) = Left pi -> PreExisting $ InstSolverPackage { instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, - instSolverPkgLibDeps = fmap (\(b, _) -> map fst b) ds', - instSolverPkgExeDeps = fmap (\(_, c) -> c) ds' + instSolverPkgLibDeps = fmap (\(b, _) -> map fst b) (ds' Nothing), + instSolverPkgExeDeps = fmap (\(_, c) -> c) (ds' Nothing) } Right pi -> Configured $ SolverPackage { solverPkgSource = srcpkg, solverPkgFlags = fa, solverPkgStanzas = es, - solverPkgLibDeps = fmap (\(b, _) -> b) ds', - solverPkgExeDeps = fmap (\(_, c) -> c) ds' + solverPkgLibDeps = fmap (\(b, _) -> b) (ds' (Just (pkgName pi))), + solverPkgExeDeps = fmap (\(_, c) -> c) (ds' (Just (pkgName pi))) } where srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where - ds' :: ComponentDeps (([(SolverId, Maybe PrivateAlias)] {- lib -}, [SolverId] {- exe -})) - ds' = fmap (partitionDeps . map convConfId) ds + ds' :: Maybe PackageName -> ComponentDeps (([(SolverId, Maybe PrivateAlias)] {- lib -}, [SolverId] {- exe -})) + ds' pn = fmap (partitionDeps . map (convConfId pn)) ds partitionDeps :: [Converted] -> (([(SolverId, Maybe PrivateAlias)], [SolverId])) partitionDeps [] = ([], []) @@ -69,8 +69,8 @@ convPI (PI (Q _ pn) (I v _)) = Right (PackageIdentifier pn v) data Converted = NormalPkg SolverId | NormalExe SolverId | AliasPkg SolverId PrivateAlias -convConfId :: PI QPN -> Converted -convConfId (PI (Q (PackagePath ns qn) pn) (I v loc)) = +convConfId :: Maybe PackageName -> PI QPN -> Converted +convConfId parent (PI (Q (PackagePath ns qn) pn) (I v loc)) = case loc of Inst pi -> NormalPkg (PreExistingId sourceId pi) _otherwise @@ -82,7 +82,10 @@ convConfId (PI (Q (PackagePath ns qn) pn) (I v loc)) = -- silly and didn't allow arbitrarily nested build-tools -- dependencies, so a shallow check works. , pn == pn' -> NormalExe (PlannedId sourceId) - | QualAlias _ _ alias _ <- qn -> AliasPkg (PlannedId sourceId) alias + -- Same reasoning as for exes, the "top" qualified goal is the one + -- which is private and needs to be aliased, but there might be other goals underneath which + -- are solved in the same scope (but are not private) + | QualAlias pn' _ alias _ <- qn, parent == Just pn' -> AliasPkg (PlannedId sourceId) alias | otherwise -> NormalPkg (PlannedId sourceId) where sourceId = PackageIdentifier pn v diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 8b5d2a43586..9b1f3af00d9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -207,7 +207,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go | Private (qpn, pkgs) <- is_private = Dep (Q (PackagePath ns (QualAlias pn comp qpn pkgs)) <$> dep) is_private ci | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) is_private ci | qSetup comp = Dep (Q (PackagePath (IndependentComponent pn ComponentSetup) QualToplevel) <$> dep) is_private ci - | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) is_private ci + | otherwise = Dep (Q (PackagePath ns (inheritedQ qpn) ) <$> dep) is_private ci -- pkg:lib-foo depends on: a @@ -230,12 +230,16 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go -- The inherited qualifier is only used for regular dependencies; for setup -- and base dependencies we override the existing qualifier. See #3160 for -- a detailed discussion. - inheritedQ :: Qualifier - inheritedQ = case q of + inheritedQ :: PackageName -> Qualifier + inheritedQ pn = case q of QualToplevel -> QualToplevel QualBase {} -> QualToplevel -- MP: TODO, check if package name is in same scope (if so, persist) - QualAlias {} -> QualToplevel + QualAlias _ _ _ pkgs -> + if pn `elem` pkgs + then traceShow ("INHERITED", pn, pkgs) q + else QualToplevel +-- traceShow (alias, pkgs) QualToplevel -- Should we qualify this goal with the 'Base' package path? qBase :: PN -> Bool diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs index 49e969a77ab..6f26503a478 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -15,6 +15,7 @@ module Distribution.Solver.Modular.Preference , onlyConstrained , sortGoals , pruneAfterFirstSuccess + , rewriteQPN ) where import Prelude () @@ -359,6 +360,14 @@ onlyConstrained p = go go x = x + +rewriteQPN :: Show d => EndoTreeTrav d QGoalReason +rewriteQPN = go + where + go x = x + + + -- | Sort all goals using the provided function. sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> EndoTreeTrav d c sortGoals variableOrder = go diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs index 39bd7bf4690..5e17e3f76ba 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -48,7 +48,7 @@ import Distribution.Simple.Setup (BooleanFlag(..)) #ifdef DEBUG_TRACETREE import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W -import qualified Distribution.Deprecated.Text as T +--import qualified Distribution.Deprecated.Text as T import Debug.Trace.Tree (gtraceJson) import Debug.Trace.Tree.Simple @@ -143,7 +143,8 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = OnlyConstrainedAll -> P.onlyConstrained pkgIsExplicit OnlyConstrainedNone -> - id) + id) . prunePhase2 + prunePhase2 = P.rewriteQPN buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals) allExplicit = M.keysSet userConstraints `S.union` userGoals @@ -201,7 +202,7 @@ instance GSimpleTree (Tree d c) where -- Show package choice goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) - goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) + goP _ (POption (I ver _loc) Nothing) subtree = (show ver, go subtree) goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) -- Show flag or stanza choice diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs index 10d372525b1..357609d85f5 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -79,6 +79,7 @@ data Tree d c = -- | We failed to find a solution in this path through the tree | Fail ConflictSet FailReason + deriving (Show) -- | A package option is a package instance with an optional linking annotation -- @@ -143,7 +144,7 @@ data TreeF d c a = | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) | DoneF RevDepMap d | FailF ConflictSet FailReason - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable, Show) out :: Tree d c -> TreeF d c (Tree d c) out (PChoice p s i ts) = PChoiceF p s i ts diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index c28161f1704..c9385bceda2 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -79,7 +79,7 @@ scopeToPackageName (ScopePrivate _ _ pn) = pn -- TOOD: Crucial constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches cs qpn | traceShow (cs, qpn) False = undefined +--constraintScopeMatches cs qpn | traceShow (cs, qpn) False = undefined constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = let namespaceMatches DefaultNamespace = True namespaceMatches (Independent namespacePn) = pn == namespacePn diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4615e1f0f5d..9d334b68d9e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -32,6 +32,7 @@ data Namespace = DefaultNamespace -- | A goal which is solved per-package + -- `--independent-goals` | Independent PackageName @@ -66,6 +67,67 @@ data Qualifier = -- A goal which is solved per-component | QualAlias PackageName Component PrivateAlias [PackageName] + +-- package: qux +-- :build-depends: foo, baz +-- +-- package: baz +-- :build-depends: wurble +-- +-- PackagePath DefaultNamespace QualToplevel "foo" +-- => PackagePath DefaultNamespace QualToplevel "wurble" +-- PackagePath DefaultNamespace QualToplevel "baz" +-- PackagePath DefaultNamespace QualToplevel "wurble" +-- +-- package: qux +-- :private-build-depends: G0 with (foo == 0.3, baz == 0.5) +-- :private-build-depends: G1 with (foo == 0.4, baz) +-- +-- package: foo +-- :build-depends: baz >= 0.5 +-- +-- PackagePath DefaultNamespace (QualAlias "qux" "MainLib" "G0" [foo, baz]) "foo" (== 0.3) +---- => PackagePath DefaultNamespace (QualAlias "qux" "MainLib" "G0") "baz" (>= 0.5) +-- => PackagePath DefaultNamespace QualTopLevel "baz" (>= 0.5) +-- PackagePath DefaultNamespace (QualAlias "qux" "MainLib" "G0") "baz" == 0.5 +-- =>>> PackagePath DefaultNamespace (QualAlias "qux" "MainLib" "G0") "baz" =>> 0.5 +-- =>>> PackagePath DefaultNamespace QualTopLevel "baz" =>> 0.6 +-- +-- +-- package a +-- :private-build-depends: G0 with (b, d) +-- +-- package b-0.1 +-- :build-depends: x +-- +-- package b-0.2 +-- :build-depends: x, d +-- +-- package b-0.3 +-- :build-depends: x, c, d +-- +-- package c-0.1 +-- :build-depends: x +-- +-- package c-0.2 +-- :build-depends: x, d +-- +-- +-- Closure property violated by `b == 0.3` and `c == 0.2` THEN closure property is violated. +-- +-- Need to be able to implicitly introduce c into the private scope so that the closure property holds. +-- +-- +-- +-- +-- +-- PackagePath DefaultNamespace (QualAlias "qux" "MainLib" "G1" ) "foo" +-- PackagePath DefaultNamespace (QualAlias "qux" "MainLib" "G1") "baz" +-- +-- package: baz +-- :build-depends: wurble +-- + {- -- | Setup dependency -- diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index d32ccc17e74..a8bb8a280ea 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -17,13 +17,10 @@ import Distribution.Package (PackageId, Package(..), UnitId) -- data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } | PlannedId { solverSrcId :: PackageId } - deriving (Eq, Ord, Generic) + deriving (Eq, Ord, Generic, Show) instance Binary SolverId instance Structured SolverId -instance Show SolverId where - show = show . solverSrcId - instance Package SolverId where packageId = solverSrcId diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index cf7fc7d20f8..0e0c0b964c3 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1873,7 +1873,7 @@ elaborateInstallPlan external_lib_dep_sids = CD.select (== compSolverName) deps0 external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 - external_lib_dep_pkgs = [ (d, alias) | (sid, alias) <- external_lib_dep_sids, d <- mapDep sid ] + external_lib_dep_pkgs = Debug.Trace.traceShow ("SIDS", external_lib_dep_sids) [ (d, alias) | (sid, alias) <- external_lib_dep_sids, d <- mapDep sid ] external_exe_dep_pkgs_raw = [ (d, Nothing) | sid <- external_exe_dep_sids, d <- mapDep sid ] @@ -1894,8 +1894,7 @@ elaborateInstallPlan exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map external_lib_cc_map = - Map.fromListWith Map.union $ - map mkCCMapping external_lib_dep_pkgs + Map.fromListWith Map.union (map mkCCMapping external_lib_dep_pkgs) external_exe_cc_map = Map.fromListWith Map.union $ map mkCCMapping external_exe_dep_pkgs