Merge pull request #6836 from fgaz/pr-6047-3

Solver: Support dependencies on sub-libraries (issue #6039) (3rd iteration)

Author: fgaz

Cabal/Distribution/Simple/Compiler.hs

@@ -63,6 +63,7 @@ module Distribution.Simple.Compiler (
         backpackSupported,
         arResponseFilesSupported,
         libraryDynDirSupported,
+        libraryVisibilitySupported,
 
         -- * Support for profiling detail levels
         ProfDetailLevel(..),
@@ -380,6 +381,15 @@ profilingSupported comp =
     GHCJS -> True
     _     -> False
 
+-- | Does this compiler support a package database entry with:
+-- "visibility"?
+libraryVisibilitySupported :: Compiler -> Bool
+libraryVisibilitySupported comp = case compilerFlavor comp of
+  GHC -> v >= mkVersion [8,8]
+  _   -> False
+ where
+  v = compilerVersion comp
+
 -- | Utility function for GHC only features
 ghcSupported :: String -> Compiler -> Bool
 ghcSupported key comp =

Cabal/Distribution/Types/CondTree.hs

@@ -140,8 +140,9 @@ traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd
 
 -- | Extract the condition matched by the given predicate from a cond tree.
 --
--- We use this mainly for extracting buildable conditions (see the Note above),
--- but the function is in fact more general.
+-- We use this mainly for extracting buildable conditions (see the Note in
+-- Distribution.PackageDescription.Configuration), but the function is in fact
+-- more general.
 extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
 extractCondition p = go
   where

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -3412,9 +3412,7 @@ setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..})
     configUserInstall         = mempty -- don't rely on defaults
     configPrograms_           = mempty -- never use, shouldn't exist
     configUseResponseFiles    = mempty
-    -- TODO set to true when the solver can prevent private-library-deps by itself
-    -- (issue #6039)
-    configAllowDependingOnPrivateLibs = mempty
+    configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler
 
 setupHsConfigureArgs :: ElaboratedConfiguredPackage
                      -> [String]

cabal-install/Distribution/Client/Setup.hs

@@ -512,6 +512,8 @@ filterConfigureFlags flags cabalLibVersion
               convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) =
                 Just $ GivenComponent pn LMainLibName cid
           in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags
+        -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'.
+      , configAllowDependingOnPrivateLibs = NoFlag
         -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'.
       , configFullyStaticExe = NoFlag
       }

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

@@ -7,6 +7,7 @@ import Prelude ()
 
 import qualified Data.List as L
 import qualified Data.Map.Strict as M
+import qualified Distribution.Compat.NonEmptySet as NonEmptySet
 import qualified Data.Set as S
 
 import qualified Distribution.InstalledPackageInfo as IPI
@@ -25,6 +26,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 +94,18 @@ convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
 convIP idx ipi =
   case traverse (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 +149,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 +223,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 +360,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 +567,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 <- NonEmptySet.toList libs ]
 
 -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.
 convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN
@@ -548,5 +581,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