wip

Author: mpickering

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
 

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

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

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

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

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

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

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

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
     --

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

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