Solver: Support dependencies on sub-libraries (issue haskell#6039).

This commit tracks dependencies on sub-libraries by extending the functionality
for tracking executables that was added in
e86f838.

It also starts adding support for library visibility, though it currently only
works for source packages.  There is a TODO for handling installed packages.

This commit handles visibility similarly to the way that the buildable field is
handled currently.  It only checks whether a component is made private by the
current environment and flag constraints at the start of dependency solving.
This means that the solver can treat a component as visible when the visibility
is controlled by an automatic flag, and the build can fail later, depending on
the value that is chosen for the flag.

Fixes haskell#6038.

cabal-install/Distribution/Solver/Modular/Dependency.hs

@@ -55,6 +55,7 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
 
 import Distribution.Solver.Types.ComponentDeps (Component(..))
 import Distribution.Solver.Types.PackagePath
+import Distribution.Types.LibraryName
 import Distribution.Types.PkgconfigVersionRange
 import Distribution.Types.UnqualComponentName
 
@@ -131,7 +132,9 @@ data PkgComponent qpn = PkgComponent qpn ExposedComponent
 
 -- | A component that can be depended upon by another package, i.e., a library
 -- or an executable.
-data ExposedComponent = ExposedLib | ExposedExe UnqualComponentName
+data ExposedComponent =
+    ExposedLib LibraryName
+  | ExposedExe UnqualComponentName
   deriving (Eq, Ord, Show)
 
 -- | The reason that a dependency is active. It identifies the package and any
@@ -185,7 +188,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 (PkgComponent "A" ExposedLib) (Constrained AnyVersion))
+    -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (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
@@ -199,7 +202,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
     goD (Pkg pkn vr)  _    = Pkg pkn vr
     goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
         Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci
-    goD (Dep dep@(PkgComponent qpn ExposedLib) ci) comp
+    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

cabal-install/Distribution/Solver/Modular/Index.hs

@@ -1,6 +1,8 @@
 module Distribution.Solver.Modular.Index
     ( Index
     , PInfo(..)
+    , ComponentInfo(..)
+    , IsVisible(..)
     , IsBuildable(..)
     , defaultQualifyOptions
     , mkIndex
@@ -30,10 +32,24 @@ type Index = Map PN (Map I PInfo)
 -- 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) (Map ExposedComponent IsBuildable) FlagInfo (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps PN)
+                   (Map ExposedComponent ComponentInfo)
+                   FlagInfo
+                   (Maybe FailReason)
+
+-- | Info associated with each library and executable in a package instance.
+data ComponentInfo = ComponentInfo {
+    compIsVisible   :: IsVisible
+  , compIsBuildable :: IsBuildable
+  }
+
+-- | Whether a component is visible in the current environment.
+newtype IsVisible = IsVisible Bool
+  deriving Eq
 
 -- | Whether a component is made unbuildable by a "buildable: False" field.
 newtype IsBuildable = IsBuildable Bool
+  deriving Eq
 
 mkIndex :: [(PN, I, PInfo)] -> Index
 mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))

cabal-install/Distribution/Solver/Modular/IndexConversion.hs

@@ -25,6 +25,7 @@ import Distribution.PackageDescription.Configuration
 import qualified Distribution.Simple.PackageIndex as SI
 import Distribution.System
 import Distribution.Types.ForeignLib
+import Distribution.Types.LibraryVisibility
 
 import           Distribution.Solver.Types.ComponentDeps
                    ( Component(..), componentNameToComponent )
@@ -92,11 +93,18 @@ convIP :: SI.InstalledPackageIndex -> IPI.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 M.empty (Just Broken))
-        Just fds -> ( pn
-                    , i
-                    , PInfo fds (M.singleton ExposedLib (IsBuildable True)) M.empty Nothing)
+        Just fds -> ( pn, i, PInfo fds components M.empty Nothing)
  where
+  -- TODO: Handle sub-libraries and visibility.
+  components =
+      M.singleton (ExposedLib LMainLibName)
+                  ComponentInfo {
+                      compIsVisible = IsVisible True
+                    , compIsBuildable = IsBuildable True
+                    }
+
   (pn, i) = convId ipi
+
   -- 'sourceLibName' is unreliable, but for now we only really use this for
   -- primary libs anyways
   comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi
@@ -140,7 +148,8 @@ 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 (PkgComponent pn ExposedLib) (Fixed i))) comp)
+                    name = ExposedLib LMainLibName  -- TODO: Handle sub-libraries.
+                in  Just (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)
                 -- NB: something we pick up from the
                 -- InstalledPackageIndex is NEVER an executable
 
@@ -213,34 +222,52 @@ convGPD os arch cinfo constraints strfl solveExes pn
         Just ver -> Just (UnsupportedSpecVer ver)
         Nothing  -> Nothing
 
-    components :: Map ExposedComponent IsBuildable
-    components = M.fromList $ libComps ++ exeComps
+    components :: Map ExposedComponent ComponentInfo
+    components = M.fromList $ libComps ++ subLibComps ++ exeComps
       where
-        libComps = [ (ExposedLib, IsBuildable $ isBuildable libBuildInfo lib)
+        libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib)
                    | lib <- maybeToList mlib ]
-        exeComps = [ (ExposedExe name, IsBuildable $ isBuildable buildInfo exe)
+        subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib)
+                      | (name, lib) <- sub_libs ]
+        exeComps = [ ( ExposedExe name
+                     , ComponentInfo {
+                           compIsVisible = IsVisible True
+                         , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False
+                         }
+                     )
                    | (name, exe) <- exes ]
-        isBuildable = isBuildableComponent os arch cinfo constraints
+
+        libToComponentInfo lib =
+            ComponentInfo {
+                compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True
+              , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False
+              }
+
+        testCondition = testConditionForComponent os arch cinfo constraints
+
+        isPrivate LibraryVisibilityPrivate = True
+        isPrivate LibraryVisibilityPublic  = False
 
   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
+-- | Applies the given predicate (for example, testing buildability or
+-- visibility) to the given component and environment. Values are combined with
+-- AND. This function returns 'Nothing' when the result cannot be determined
+-- before dependency solving. Additionally, this function only considers flags
+-- that are set by unqualified flag constraints, and it doesn't check the
+-- intra-package dependencies of a component.
+testConditionForComponent :: OS
+                          -> Arch
+                          -> CompilerInfo
+                          -> [LabeledPackageConstraint]
+                          -> (a -> Bool)
+                          -> CondTree ConfVar [Dependency] a
+                          -> Maybe Bool
+testConditionForComponent os arch cinfo constraints p tree =
+    case simplifyCondition $ extractCondition p tree of
+      Lit True  -> Just True
+      Lit False -> Just False
+      _         -> Nothing
   where
     flagAssignment :: [(FlagName, Bool)]
     flagAssignment =
@@ -332,8 +359,10 @@ convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(Solv
              -- duplicates could grow exponentially from the leaves to the root
              -- of the tree.
              mergeSimpleDeps $
-                 L.map (\d -> D.Simple (convLibDep dr d) comp)
-                       (mapMaybe (filterIPNs ipns) ds)                                -- unconditional package dependencies
+                 [ D.Simple singleDep comp
+                 | dep <- mapMaybe (filterIPNs ipns) ds
+                 , singleDep <- convLibDeps dr dep ]  -- unconditional package dependencies
+
               ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (allExtensions bi) -- unconditional extension dependencies
               ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages  bi) -- unconditional language dependencies
               ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies
@@ -537,9 +566,12 @@ unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn
 unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =
     DependencyReason pn' (M.union fs1 fs2) (S.union ss1 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 (PkgComponent pn ExposedLib) (Constrained vr)
+-- | Convert a Cabal dependency on a set of library components (from a single
+-- package) to solver-specific dependencies.
+convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN]
+convLibDeps dr (Dependency pn vr libs) =
+    [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr)
+    | lib <- S.toList libs ]
 
 -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.
 convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN
@@ -548,5 +580,6 @@ convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (Expose
 -- | Convert setup dependencies
 convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN
 convSetupBuildInfo pn nfo =
-    L.map (\d -> D.Simple (convLibDep (DependencyReason pn M.empty S.empty) d) ComponentSetup)
-          (setupDepends nfo)
+    [ D.Simple singleDep ComponentSetup
+    | dep <- setupDepends nfo
+    , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ]

cabal-install/Distribution/Solver/Modular/Message.hs

@@ -25,6 +25,7 @@ import Distribution.Solver.Modular.Version
 import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
+import Distribution.Types.LibraryName
 import Distribution.Types.UnqualComponentName
 
 data Message =
@@ -220,8 +221,10 @@ 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 _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it 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 _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)"
 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)"
@@ -247,8 +250,9 @@ showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA
 showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
 
 showExposedComponent :: ExposedComponent -> String
-showExposedComponent ExposedLib = "library"
-showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'"
+showExposedComponent (ExposedLib LMainLibName)       = "library"
+showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"
+showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"
 
 constraintSource :: ConstraintSource -> String
 constraintSource src = "constraint from " ++ showConstraintSource src
@@ -257,8 +261,9 @@ showConflictingDep :: ConflictingDep -> String
 showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
   let DependencyReason qpn' _ _ = dr
       componentStr = case comp of
-                       ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")"
-                       ExposedLib     -> ""
+                       ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"
+                       ExposedLib LMainLibName      -> ""
+                       ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")"
   in case ci of
        Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
                          showQPN qpn ++ componentStr ++ "==" ++ showI i

cabal-install/Distribution/Solver/Modular/Tree.hs

@@ -102,8 +102,10 @@ data FailReason = UnsupportedExtension Extension
                 | NewPackageDoesNotMatchExistingConstraint ConflictingDep
                 | ConflictingConstraints ConflictingDep ConflictingDep
                 | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)
+                | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN)
                 | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN)
                 | PackageRequiresMissingComponent QPN ExposedComponent
+                | PackageRequiresPrivateComponent QPN ExposedComponent
                 | PackageRequiresUnbuildableComponent QPN ExposedComponent
                 | CannotInstall
                 | CannotReinstall