Solver: Enforce dependencies on libraries (fixes #779).

grayjay · hvr · commit fe2110d8bab5 · 2018-06-08T17:04:15.000+02:00
This commit generalizes the fix for issue #4781 (e86f838) by tracking dependencies on components instead of dependencies on executables. That means that the solver always checks whether a package contains a library before using it to satisfy a build-depends dependency. If a version of a package doesn't contain a library, the solver can try other versions. Associating each dependency with a component also moves towards the design for component-based dependency solving described in issue #4087. (cherry picked from commit 6efb5e2)
diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs
@@ -72,7 +72,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
       -- the later addition will have better dependency information.
     go g o ((Stanza sn@(SN qpn _) t)           : ngs) =
         go g (StanzaGoal sn t (flagGR qpn) : o) ngs
-    go g o ((Simple (LDep dr (Dep _ qpn _)) c) : ngs)
+    go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs)
       | qpn == qpn'       =
             -- We currently only add a self-dependency to the graph if it is
             -- between a package and its setup script. The edge creates a cycle
diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs
@@ -16,6 +16,8 @@ module Distribution.Solver.Modular.Dependency (
   , FlaggedDep(..)
   , LDep(..)
   , Dep(..)
+  , PkgComponent(..)
+  , ExposedComponent(..)
   , DependencyReason(..)
   , showDependencyReason
   , flattenFlaggedDeps
@@ -112,12 +114,22 @@ 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 (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
+data Dep qpn = Dep (PkgComponent qpn) CI  -- ^ dependency on a package component
+             | 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
 
+-- | An exposed component within a package. This type is used to represent
+-- build-depends and build-tool-depends dependencies.
+data PkgComponent qpn = PkgComponent qpn ExposedComponent
+  deriving (Eq, Ord, Functor, Show)
+
+-- | A component that can be depended upon by another package, i.e., a library
+-- or an executable.
+data ExposedComponent = ExposedLib | ExposedExe UnqualComponentName
+  deriving (Eq, Ord, Show)
+
 -- | The reason that a dependency is active. It identifies the package and any
 -- flag and stanza choices that introduced the dependency. It contains
 -- everything needed for creating ConflictSets or describing conflicts in solver
@@ -169,7 +181,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 Nothing "A" (Constrained AnyVersion))
+    -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" ExposedLib) (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
@@ -181,11 +193,12 @@ 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 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
+    goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
+        Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci
+    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
 
     -- 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
@@ -13,20 +13,19 @@ 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
 -- to info.
 type Index = Map PN (Map I PInfo)
 
 -- | Info associated with a package instance.
--- Currently, dependencies, executable names, flags and failure reasons.
+-- Currently, dependencies, component 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) [UnqualComponentName] FlagInfo (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps PN) [ExposedComponent] FlagInfo (Maybe FailReason)
 
 mkIndex :: [(PN, I, PInfo)] -> Index
 mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
@@ -40,9 +39,9 @@ defaultQualifyOptions idx = QO {
                               | -- Find all versions of base ..
                                 Just is <- [M.lookup base idx]
                                 -- .. which are installed ..
-                              , (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is
+                              , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is
                                 -- .. and flatten all their dependencies ..
-                              , (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps
+                              , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps
                               ]
     , qoSetupIndependent = True
     }
diff --git a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs
@@ -72,7 +72,8 @@ convIPI' (ShadowPkgs sip) idx =
   where
 
     -- shadowing is recorded in the package info
-    shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed))
+    shadow (pn, i, PInfo fdeps comps fds _)
+      | sip = (pn, i, PInfo fdeps comps 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.
@@ -87,7 +88,7 @@ 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 [] M.empty Nothing)
+        Just fds -> (pn, i, PInfo fds [ExposedLib] M.empty Nothing)
  where
   (pn, i) = convId ipi
   -- 'sourceLibName' is unreliable, but for now we only really use this for
@@ -133,7 +134,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 Nothing pn (Fixed i))) comp)
+                in  Just (D.Simple (LDep dr (Dep (PkgComponent pn ExposedLib) (Fixed i))) comp)
                 -- NB: something we pick up from the
                 -- InstalledPackageIndex is NEVER an executable
 
@@ -223,7 +224,7 @@ convGPD os arch cinfo strfl solveExes pn
     fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer)
        | otherwise               = Nothing
   in
-    PInfo flagged_deps (L.map fst exes) fds fr
+    PInfo flagged_deps (L.map (ExposedExe . fst) exes ++ [ExposedLib | isJust mlib]) fds fr
 
 -- | Create a flagged dependency tree from a list @fds@ of flagged
 -- dependencies, using @f@ to form the tree node (@f@ will be
@@ -289,7 +290,7 @@ convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(Solv
     bi = getInfo info
 
 data SimpleFlaggedDepKey qpn =
-    SimpleFlaggedDepKey (Maybe UnqualComponentName) qpn Component
+    SimpleFlaggedDepKey (PkgComponent qpn) Component
   deriving (Eq, Ord)
 
 data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR
@@ -320,9 +321,9 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge
           => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)
           -> FlaggedDep qpn
           -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)
-        f (merged', unmerged') (D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp) =
+        f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) =
             ( M.insertWith mergeValues
-                           (SimpleFlaggedDepKey mExe qpn comp)
+                           (SimpleFlaggedDepKey dep comp)
                            (SimpleFlaggedDepValue dr vr)
                            merged'
             , unmerged')
@@ -337,8 +338,8 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge
     toFlaggedDep :: SimpleFlaggedDepKey qpn
                  -> SimpleFlaggedDepValue qpn
                  -> FlaggedDep qpn
-    toFlaggedDep (SimpleFlaggedDepKey mExe qpn comp) (SimpleFlaggedDepValue dr vr) =
-        D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp
+    toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) =
+        D.Simple (LDep dr (Dep dep (Constrained vr))) comp
 
 -- | Branch interpreter.  Mutually recursive with 'convCondTree'.
 --
@@ -463,11 +464,10 @@ convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBr
         -- Union the DependencyReasons, because the extracted dependency can be
         -- avoided by removing the dependency from either side of the
         -- conditional.
-        [ D.Simple (LDep (unionDRs vs1 vs2) (Dep mExe1 pn1 (Constrained $ vr1 .||. vr2))) comp
-        | D.Simple (LDep vs1                (Dep mExe1 pn1 (Constrained vr1))) _ <- ps
-        , D.Simple (LDep vs2                (Dep mExe2 pn2 (Constrained vr2))) _ <- ps'
-        , pn1 == pn2
-        , mExe1 == mExe2
+        [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp
+        | D.Simple (LDep vs1                (Dep dep1 (Constrained vr1))) _ <- ps
+        , D.Simple (LDep vs2                (Dep dep2 (Constrained vr2))) _ <- ps'
+        , dep1 == dep2
         ]
 
 -- | Merge DependencyReasons by unioning their variables.
@@ -477,11 +477,11 @@ unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 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 Nothing pn (Constrained vr)
+convLibDep dr (Dependency pn vr) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr)
 
 -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.
 convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN
-convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr)
+convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (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
@@ -245,7 +245,7 @@ linkDeps target = \deps -> do
 
     go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
     go1 dep rdep = case (dep, rdep) of
-      (Simple (LDep dr1 (Dep _ qpn _)) _, ~(Simple (LDep dr2 (Dep _ qpn' _)) _)) -> do
+      (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do
         vs <- get
         let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs
             lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs
@@ -115,8 +115,8 @@ showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ display l
 showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)"
 showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"
 showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"
-showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")"
-showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)"
+showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"
+showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"
 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)"
@@ -138,17 +138,21 @@ showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CH
 showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
 showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
 
+showExposedComponent :: ExposedComponent -> String
+showExposedComponent ExposedLib = "library"
+showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'"
+
 constraintSource :: ConstraintSource -> String
 constraintSource src = "constraint from " ++ showConstraintSource src
 
 showConflictingDep :: ConflictingDep -> String
-showConflictingDep (ConflictingDep dr mExe qpn ci) =
+showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
   let DependencyReason qpn' _ _ = dr
-      exeStr = case mExe of
-                 Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")"
-                 Nothing  -> ""
+      componentStr = case comp of
+                       ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")"
+                       ExposedLib     -> ""
   in case ci of
        Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
-                         showQPN qpn ++ exeStr ++ "==" ++ showI i
+                         showQPN qpn ++ componentStr ++ "==" ++ showI i
        Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++
-                         exeStr ++ showVR vr
+                         componentStr ++ showVR vr
diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs
@@ -31,7 +31,6 @@ 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
@@ -101,8 +100,8 @@ data FailReason = UnsupportedExtension Extension
                 | MissingPkgconfigPackage PkgconfigName VR
                 | NewPackageDoesNotMatchExistingConstraint ConflictingDep
                 | ConflictingConstraints ConflictingDep ConflictingDep
-                | NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN)
-                | PackageRequiresMissingExe QPN UnqualComponentName
+                | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)
+                | PackageRequiresMissingComponent QPN ExposedComponent
                 | CannotInstall
                 | CannotReinstall
                 | Shadowed
@@ -123,7 +122,7 @@ data FailReason = UnsupportedExtension Extension
   deriving (Eq, Show)
 
 -- | Information about a dependency involved in a conflict, for error messages.
-data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI
+data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent 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
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
