Solver: Check whether components are buildable in the current environ…

…ment.

This commit handles the most common case of issue haskell#5325 by checking that each
component that is required as a dependency is buildable in the current
environment, where environment refers to the compiler, os, arch, and global flag
constraints.  The solver records whether each component is buildable in the
package's PInfo during index conversion.  Then it checks that each required
component is buildable in the validation phase, similar to the check for missing
components.

The buildable check can give false-positives, because 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.  The check is also
incomplete because it is performed before any automatic flags are assigned.  It
is possible for the solver to later choose a value for a flag that makes the
package unbuildable.

cabal-install/Distribution/Solver/Modular.hs

@@ -59,7 +59,7 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
   solve' sc cinfo idx pkgConfigDB pprefs gcs pns
     where
       -- Indices have to be converted into solver-specific uniform index.
-      idx    = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
+      idx    = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
       -- Constraints have to be converted into a finite map indexed by PN.
       gcs    = M.fromListWith (++) (map pair pcs)
         where

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

@@ -1,6 +1,7 @@
 module Distribution.Solver.Modular.Index
     ( Index
     , PInfo(..)
+    , IsBuildable(..)
     , defaultQualifyOptions
     , mkIndex
     ) where
@@ -21,11 +22,16 @@ type Index = Map PN (Map I PInfo)
 
 -- | Info associated with a package instance.
 -- Currently, dependencies, component names, flags and failure reasons.
+-- The component map records whether any components are unbuildable in the
+-- current environment (compiler, os, arch, and global flag constraints).
 -- 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) [ExposedComponent] FlagInfo (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps PN) (Map ExposedComponent IsBuildable) FlagInfo (Maybe FailReason)
+
+-- | Whether a component is made unbuildable by a "buildable: False" field.
+newtype IsBuildable = IsBuildable Bool
 
 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

@@ -30,7 +30,9 @@ import Distribution.Types.ForeignLib
 import           Distribution.Solver.Types.ComponentDeps
                    ( Component(..), componentNameToComponent )
 import           Distribution.Solver.Types.Flag
+import           Distribution.Solver.Types.LabeledPackageConstraint
 import           Distribution.Solver.Types.OptionalStanza
+import           Distribution.Solver.Types.PackageConstraint
 import qualified Distribution.Solver.Types.PackageIndex as CI
 import           Distribution.Solver.Types.Settings
 import           Distribution.Solver.Types.SourcePackage
@@ -53,10 +55,13 @@ import Distribution.Solver.Modular.Version
 -- resolving these situations. However, the right thing to do is to
 -- fix the problem there, so for now, shadowing is only activated if
 -- explicitly requested.
-convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables ->
-           SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index
-convPIs os arch comp sip strfl solveExes iidx sidx =
-  mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl solveExes sidx)
+convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+        -> ShadowPkgs -> StrongFlags -> SolveExecutables
+        -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)
+        -> Index
+convPIs os arch comp constraints sip strfl solveExes iidx sidx =
+  mkIndex $
+  convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx
 
 -- | Convert a Cabal installed package index to the simpler,
 -- more uniform index format of the solver.
@@ -87,8 +92,10 @@ convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)
 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 [ExposedLib] M.empty Nothing)
+        Nothing  -> (pn, i, PInfo [] M.empty M.empty (Just Broken))
+        Just fds -> ( pn
+                    , i
+                    , PInfo fds (M.singleton ExposedLib (IsBuildable True)) M.empty Nothing)
  where
   (pn, i) = convId ipi
   -- 'sourceLibName' is unreliable, but for now we only really use this for
@@ -140,24 +147,29 @@ convIPId dr comp idx ipid =
 
 -- | Convert a cabal-install source package index to the simpler,
 -- more uniform index format of the solver.
-convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables ->
-            CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
-convSPI' os arch cinfo strfl solveExes = L.map (convSP os arch cinfo strfl solveExes) . CI.allPackages
+convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+         -> StrongFlags -> SolveExecutables
+         -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
+convSPI' os arch cinfo constraints strfl solveExes =
+    L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages
 
 -- | Convert a single source package into the solver-specific format.
-convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
-convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
+convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+       -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
+convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
   let i = I pv InRepo
-  in  (pn, i, convGPD os arch cinfo strfl solveExes pn gpd)
+      pkgConstraints = fromMaybe [] $ M.lookup pn constraints
+  in  (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)
 
 -- We do not use 'flattenPackageDescription' or 'finalizePD'
 -- from 'Distribution.PackageDescription.Configuration' here, because we
 -- want to keep the condition tree, but simplify much of the test.
 
 -- | Convert a generic package description to a solver-specific 'PInfo'.
-convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables ->
-           PN -> GenericPackageDescription -> PInfo
-convGPD os arch cinfo strfl solveExes pn
+convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]
+        -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription
+        -> PInfo
+convGPD os arch cinfo constraints strfl solveExes pn
         (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) =
   let
     fds  = flagInfo strfl flags
@@ -223,8 +235,81 @@ convGPD os arch cinfo strfl solveExes pn
     -- forced to, emit a meaningful solver error message).
     fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer)
        | otherwise               = Nothing
-  in
-    PInfo flagged_deps (L.map (ExposedExe . fst) exes ++ [ExposedLib | isJust mlib]) fds fr
+
+    components :: Map ExposedComponent IsBuildable
+    components = M.fromList $ libComps ++ exeComps
+      where
+        libComps = [ (ExposedLib, IsBuildable $ isBuildable libBuildInfo lib)
+                   | lib <- maybeToList mlib ]
+        exeComps = [ (ExposedExe name, IsBuildable $ isBuildable buildInfo exe)
+                   | (name, exe) <- exes ]
+        isBuildable = isBuildableComponent os arch cinfo constraints
+
+  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
+  where
+    flagAssignment :: [(FlagName, Bool)]
+    flagAssignment =
+        mconcat [ unFlagAssignment fa
+                | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa)
+                    <- L.map unlabelPackageConstraint constraints]
+
+    -- Simplify the condition, using the current environment. Most of this
+    -- function was copied from convBranch and
+    -- Distribution.Types.Condition.simplifyCondition.
+    simplifyCondition :: Condition ConfVar -> Condition ConfVar
+    simplifyCondition (Var (OS os')) = Lit (os == os')
+    simplifyCondition (Var (Arch arch')) = Lit (arch == arch')
+    simplifyCondition (Var (Impl cf cvr))
+        | matchImpl (compilerInfoId cinfo) ||
+              -- fixme: Nothing should be treated as unknown, rather than empty
+              --        list. This code should eventually be changed to either
+              --        support partial resolution of compiler flags or to
+              --        complain about incompletely configured compilers.
+          any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True
+        | otherwise = Lit False
+      where
+        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv
+    simplifyCondition (Var (Flag f))
+        | Just b <- L.lookup f flagAssignment = Lit b
+    simplifyCondition (Var v) = Var v
+    simplifyCondition (Lit b) = Lit b
+    simplifyCondition (CNot c) =
+        case simplifyCondition c of
+          Lit True -> Lit False
+          Lit False -> Lit True
+          c' -> CNot c'
+    simplifyCondition (COr c d) =
+        case (simplifyCondition c, simplifyCondition d) of
+          (Lit False, d') -> d'
+          (Lit True, _)   -> Lit True
+          (c', Lit False) -> c'
+          (_, Lit True)   -> Lit True
+          (c', d')        -> COr c' d'
+    simplifyCondition (CAnd c d) =
+        case (simplifyCondition c, simplifyCondition d) of
+          (Lit False, _) -> Lit False
+          (Lit True, d') -> d'
+          (_, Lit False) -> Lit False
+          (c', Lit True) -> c'
+          (c', d')       -> CAnd c' d'
 
 -- | Create a flagged dependency tree from a list @fds@ of flagged
 -- dependencies, using @f@ to form the tree node (@f@ will be

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

@@ -110,7 +110,9 @@ 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 _ (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 _ (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)"
 showFR _ Shadowed                         = " (shadowed by another installed package with same version)"

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

@@ -101,7 +101,9 @@ data FailReason = UnsupportedExtension Extension
                 | NewPackageDoesNotMatchExistingConstraint ConflictingDep
                 | ConflictingConstraints ConflictingDep ConflictingDep
                 | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)
+                | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN)
                 | PackageRequiresMissingComponent QPN ExposedComponent
+                | PackageRequiresUnbuildableComponent QPN ExposedComponent
                 | CannotInstall
                 | CannotReinstall
                 | Shadowed

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

@@ -108,8 +108,8 @@ data ValidateState = VS {
   pa                  :: PreAssignment,
 
   -- Map from package name to the components that are provided by the chosen
-  -- instance of that package.
-  availableComponents :: Map QPN [ExposedComponent],
+  -- instance of that package, and whether those components are buildable.
+  availableComponents :: Map QPN (Map ExposedComponent IsBuildable),
 
   -- Map from package name to the components that are required from that
   -- package.
@@ -226,7 +226,7 @@ validate = cata go
               newDeps = do
                 nppa <- mnppa
                 rComps' <- extendRequiredComponents aComps rComps newactives
-                checkComponentsInNewPackage rComps qpn comps
+                checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps
                 return (nppa, rComps')
           in case newDeps of
                Left (c, fr)          -> -- We have an inconsistency. We can stop.
@@ -299,17 +299,31 @@ validate = cata go
             local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r
 
 -- | Check that a newly chosen package instance contains all components that
--- are required from that package so far.
-checkComponentsInNewPackage :: Map QPN ComponentDependencyReasons
+-- are required from that package so far. The components must also be buildable.
+checkComponentsInNewPackage :: ComponentDependencyReasons
                             -> QPN
-                            -> [ExposedComponent]
+                            -> Map ExposedComponent IsBuildable
                             -> Either Conflict ()
 checkComponentsInNewPackage required qpn providedComps =
-    case M.toList $ deleteKeys providedComps (M.findWithDefault M.empty qpn required) of
-      (missingComp, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr
-                               in Left (cs, NewPackageIsMissingRequiredComponent missingComp dr)
-      []                    -> Right ()
+    case M.toList $ deleteKeys (M.keys providedComps) required of
+      (missingComp, dr) : _ ->
+          Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent
+      []                    ->
+          case M.toList $ deleteKeys buildableProvidedComps required of
+            (unbuildableComp, dr) : _ ->
+                Left $ mkConflict unbuildableComp dr NewPackageHasUnbuildableRequiredComponent
+            []                        -> Right ()
   where
+    mkConflict :: ExposedComponent
+               -> DependencyReason QPN
+               -> (ExposedComponent -> DependencyReason QPN -> FailReason)
+               -> Conflict
+    mkConflict comp dr mkFailure =
+        (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure comp dr)
+
+    buildableProvidedComps :: [ExposedComponent]
+    buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps]
+
     deleteKeys :: Ord k => [k] -> Map k v -> Map k v
     deleteKeys ks m = L.foldr M.delete m ks
 
@@ -466,9 +480,9 @@ merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Const
 
 -- | Takes a list of new dependencies and uses it to try to update the map of
 -- known component dependencies. It returns a failure when a new dependency
--- requires a component that is missing from one of the previously chosen
+-- requires a component that is missing or unbuildable in a previously chosen
 -- packages.
-extendRequiredComponents :: Map QPN [ExposedComponent]
+extendRequiredComponents :: Map QPN (Map ExposedComponent IsBuildable)
                          -> Map QPN ComponentDependencyReasons
                          -> [LDep QPN]
                          -> Either Conflict (Map QPN ComponentDependencyReasons)
@@ -483,11 +497,26 @@ extendRequiredComponents available = foldM extendSingle
          -- already been chosen.
          case M.lookup qpn available of
            Just comps
-             | L.notElem comp comps -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr)
-                                       in Left (cs, PackageRequiresMissingComponent qpn comp)
-           _                        -> Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required
+             | M.notMember comp comps                ->
+                 Left $ mkConflict qpn comp dr PackageRequiresMissingComponent
+             | L.notElem comp (buildableComps comps) ->
+                 Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent
+           _                                         ->
+                 Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required
     extendSingle required _                                         = Right required
 
+    mkConflict :: QPN
+               -> ExposedComponent
+               -> DependencyReason QPN
+               -> (QPN -> ExposedComponent -> FailReason)
+               -> Conflict
+    mkConflict qpn comp dr mkFailure =
+      (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure qpn comp)
+
+    buildableComps :: Map comp IsBuildable -> [comp]
+    buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps]
+
+
 -- | Interface.
 validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c
 validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {