{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
#ifdef DEBUG_CONFLICT_SETS
{-# LANGUAGE ImplicitParams #-}
#endif
module Distribution.Solver.Modular.Validate (validateTree) where

-- Validation of the tree.
--
-- The task here is to make sure all constraints hold. After validation, any
-- assignment returned by exploration of the tree should be a complete valid
-- assignment, i.e., actually constitute a solution.

import Control.Monad.Reader
import Data.Either (lefts)
import Data.Function (on)

import qualified Data.List as L
import qualified Data.Set as S

import Language.Haskell.Extension (Extension, Language)

import Data.Map.Strict as M
import Distribution.Compiler (CompilerInfo(..))

import Distribution.Solver.Modular.Assignment
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Modular.Version
import qualified Distribution.Solver.Modular.WeightedPSQ as W

import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)
import Distribution.Types.LibraryName
import Distribution.Types.PkgconfigVersionRange

#ifdef DEBUG_CONFLICT_SETS
import GHC.Stack (CallStack)
#endif

-- In practice, most constraints are implication constraints (IF we have made
-- a number of choices, THEN we also have to ensure that). We call constraints
-- that for which the preconditions are fulfilled ACTIVE. We maintain a set
-- of currently active constraints that we pass down the node.
--
-- We aim at detecting inconsistent states as early as possible.
--
-- Whenever we make a choice, there are two things that need to happen:
--
--   (1) We must check that the choice is consistent with the currently
--       active constraints.
--
--   (2) The choice increases the set of active constraints. For the new
--       active constraints, we must check that they are consistent with
--       the current state.
--
-- We can actually merge (1) and (2) by saying the current choice is
-- a new active constraint, fixing the choice.
--
-- If a test fails, we have detected an inconsistent state. We can
-- disable the current subtree and do not have to traverse it any further.
--
-- We need a good way to represent the current state, i.e., the current
-- set of active constraints. Since the main situation where we have to
-- search in it is (1), it seems best to store the state by package: for
-- every package, we store which versions are still allowed. If for any
-- package, we have inconsistent active constraints, we can also stop.
-- This is a particular way to read task (2):
--
--   (2, weak) We only check if the new constraints are consistent with
--       the choices we've already made, and add them to the active set.
--
--   (2, strong) We check if the new constraints are consistent with the
--       choices we've already made, and the constraints we already have.
--
-- It currently seems as if we're implementing the weak variant. However,
-- when used together with 'preferEasyGoalChoices', we will find an
-- inconsistent state in the very next step.
--
-- What do we do about flags?
--
-- Like for packages, we store the flag choices we have already made.
-- Now, regarding (1), we only have to test whether we've decided the
-- current flag before. Regarding (2), the interesting bit is in discovering
-- the new active constraints. To this end, we look up the constraints for
-- the package the flag belongs to, and traverse its flagged dependencies.
-- Wherever we find the flag in question, we start recording dependencies
-- underneath as new active dependencies. If we encounter other flags, we
-- check if we've chosen them already and either proceed or stop.

-- | The state needed during validation.
data ValidateState = VS {
  ValidateState -> Extension -> Bool
supportedExt        :: Extension -> Bool,
  ValidateState -> Language -> Bool
supportedLang       :: Language  -> Bool,
  ValidateState -> PkgconfigName -> PkgconfigVersionRange -> Bool
presentPkgs         :: PkgconfigName -> PkgconfigVersionRange  -> Bool,
  ValidateState -> Index
index               :: Index,

  -- Saved, scoped, dependencies. Every time 'validate' makes a package choice,
  -- it qualifies the package's dependencies and saves them in this map. Then
  -- the qualified dependencies are available for subsequent flag and stanza
  -- choices for the same package.
  ValidateState -> Map QPN (FlaggedDeps QPN)
saved               :: Map QPN (FlaggedDeps QPN),

  ValidateState -> PreAssignment
pa                  :: PreAssignment,

  -- Map from package name to the components that are provided by the chosen
  -- instance of that package, and whether those components are visible and
  -- buildable.
  ValidateState -> Map QPN (Map ExposedComponent ComponentInfo)
availableComponents :: Map QPN (Map ExposedComponent ComponentInfo),

  -- Map from package name to the components that are required from that
  -- package.
  ValidateState -> Map QPN ComponentDependencyReasons
requiredComponents  :: Map QPN ComponentDependencyReasons,

  ValidateState -> QualifyOptions
qualifyOptions      :: QualifyOptions
}

newtype Validate a = Validate (Reader ValidateState a)
  deriving (a -> Validate b -> Validate a
(a -> b) -> Validate a -> Validate b
(forall a b. (a -> b) -> Validate a -> Validate b)
-> (forall a b. a -> Validate b -> Validate a) -> Functor Validate
forall a b. a -> Validate b -> Validate a
forall a b. (a -> b) -> Validate a -> Validate b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Validate b -> Validate a
$c<$ :: forall a b. a -> Validate b -> Validate a
fmap :: (a -> b) -> Validate a -> Validate b
$cfmap :: forall a b. (a -> b) -> Validate a -> Validate b
Functor, Functor Validate
a -> Validate a
Functor Validate
-> (forall a. a -> Validate a)
-> (forall a b. Validate (a -> b) -> Validate a -> Validate b)
-> (forall a b c.
    (a -> b -> c) -> Validate a -> Validate b -> Validate c)
-> (forall a b. Validate a -> Validate b -> Validate b)
-> (forall a b. Validate a -> Validate b -> Validate a)
-> Applicative Validate
Validate a -> Validate b -> Validate b
Validate a -> Validate b -> Validate a
Validate (a -> b) -> Validate a -> Validate b
(a -> b -> c) -> Validate a -> Validate b -> Validate c
forall a. a -> Validate a
forall a b. Validate a -> Validate b -> Validate a
forall a b. Validate a -> Validate b -> Validate b
forall a b. Validate (a -> b) -> Validate a -> Validate b
forall a b c.
(a -> b -> c) -> Validate a -> Validate b -> Validate c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Validate a -> Validate b -> Validate a
$c<* :: forall a b. Validate a -> Validate b -> Validate a
*> :: Validate a -> Validate b -> Validate b
$c*> :: forall a b. Validate a -> Validate b -> Validate b
liftA2 :: (a -> b -> c) -> Validate a -> Validate b -> Validate c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Validate a -> Validate b -> Validate c
<*> :: Validate (a -> b) -> Validate a -> Validate b
$c<*> :: forall a b. Validate (a -> b) -> Validate a -> Validate b
pure :: a -> Validate a
$cpure :: forall a. a -> Validate a
$cp1Applicative :: Functor Validate
Applicative, Applicative Validate
a -> Validate a
Applicative Validate
-> (forall a b. Validate a -> (a -> Validate b) -> Validate b)
-> (forall a b. Validate a -> Validate b -> Validate b)
-> (forall a. a -> Validate a)
-> Monad Validate
Validate a -> (a -> Validate b) -> Validate b
Validate a -> Validate b -> Validate b
forall a. a -> Validate a
forall a b. Validate a -> Validate b -> Validate b
forall a b. Validate a -> (a -> Validate b) -> Validate b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Validate a
$creturn :: forall a. a -> Validate a
>> :: Validate a -> Validate b -> Validate b
$c>> :: forall a b. Validate a -> Validate b -> Validate b
>>= :: Validate a -> (a -> Validate b) -> Validate b
$c>>= :: forall a b. Validate a -> (a -> Validate b) -> Validate b
$cp1Monad :: Applicative Validate
Monad, MonadReader ValidateState)

runValidate :: Validate a -> ValidateState -> a
runValidate :: Validate a -> ValidateState -> a
runValidate (Validate Reader ValidateState a
r) = Reader ValidateState a -> ValidateState -> a
forall r a. Reader r a -> r -> a
runReader Reader ValidateState a
r

-- | A preassignment comprises knowledge about variables, but not
-- necessarily fixed values.
data PreAssignment = PA PPreAssignment FAssignment SAssignment

-- | A (partial) package preassignment. Qualified package names
-- are associated with MergedPkgDeps.
type PPreAssignment = Map QPN MergedPkgDep

-- | A dependency on a component, including its DependencyReason.
data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI

-- | Map from component name to one of the reasons that the component is
-- required.
type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN)

-- | MergedPkgDep records constraints about the instances that can still be
-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a
-- list of version ranges paired with the goals / variables that introduced
-- them. It also records whether a package is a build-tool dependency, for each
-- reason that it was introduced.
--
-- It is important to store the component name with the version constraint, for
-- error messages, because whether something is a build-tool dependency affects
-- its qualifier, which affects which constraint is applied.
data MergedPkgDep =
    MergedDepFixed ExposedComponent (DependencyReason QPN) I
  | MergedDepConstrained [VROrigin]

-- | Version ranges paired with origins.
type VROrigin = (VR, ExposedComponent, DependencyReason QPN)

-- | The information needed to create a 'Fail' node.
type Conflict = (ConflictSet, FailReason)

validate :: Tree d c -> Validate (Tree d c)
validate :: Tree d c -> Validate (Tree d c)
validate = Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go
  where
    go :: Tree d c -> Validate (Tree d c)

    go :: Tree d c -> Validate (Tree d c)
go (PChoice QPN
qpn RevDepMap
rdm c
gr       WeightedPSQ [Weight] POption (Tree d c)
ts) = QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
forall d c.
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
PChoice QPN
qpn RevDepMap
rdm c
gr (WeightedPSQ [Weight] POption (Tree d c) -> Tree d c)
-> Validate (WeightedPSQ [Weight] POption (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (POption -> Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] POption (Tree d c)
-> Validate (WeightedPSQ [Weight] POption (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (\POption
k -> QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP QPN
qpn POption
k (Validate (Tree d c) -> Validate (Tree d c))
-> (Tree d c -> Validate (Tree d c))
-> Tree d c
-> Validate (Tree d c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go) WeightedPSQ [Weight] POption (Tree d c)
ts
    go (FChoice QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
b FlagType
m Bool
d WeightedPSQ [Weight] Bool (Tree d c)
ts) =
      do
        -- Flag choices may occur repeatedly (because they can introduce new constraints
        -- in various places). However, subsequent choices must be consistent. We thereby
        -- collapse repeated flag choice nodes.
        PA PPreAssignment
_ FAssignment
pfa SAssignment
_ <- (ValidateState -> PreAssignment) -> Validate PreAssignment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PreAssignment
pa -- obtain current flag-preassignment
        case QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QFN
qfn FAssignment
pfa of
          Just Bool
rb -> -- flag has already been assigned; collapse choice to the correct branch
                     case Bool -> WeightedPSQ [Weight] Bool (Tree d c) -> Maybe (Tree d c)
forall k w v. Eq k => k -> WeightedPSQ w k v -> Maybe v
W.lookup Bool
rb WeightedPSQ [Weight] Bool (Tree d c)
ts of
                       Just Tree d c
t  -> QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF QFN
qfn Bool
rb (Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go Tree d c
t)
                       Maybe (Tree d c)
Nothing -> Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail (Var QPN -> ConflictSet
varToConflictSet (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn)) (QFN -> FailReason
MalformedFlagChoice QFN
qfn)
          Maybe Bool
Nothing -> -- flag choice is new, follow both branches
                     QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
FChoice QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
b FlagType
m Bool
d (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> Validate (WeightedPSQ [Weight] Bool (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Validate (WeightedPSQ [Weight] Bool (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (\Bool
k -> QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF QFN
qfn Bool
k (Validate (Tree d c) -> Validate (Tree d c))
-> (Tree d c -> Validate (Tree d c))
-> Tree d c
-> Validate (Tree d c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go) WeightedPSQ [Weight] Bool (Tree d c)
ts
    go (SChoice QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
b   WeightedPSQ [Weight] Bool (Tree d c)
ts) =
      do
        -- Optional stanza choices are very similar to flag choices.
        PA PPreAssignment
_ FAssignment
_ SAssignment
psa <- (ValidateState -> PreAssignment) -> Validate PreAssignment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PreAssignment
pa -- obtain current stanza-preassignment
        case QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QSN
qsn SAssignment
psa of
          Just Bool
rb -> -- stanza choice has already been made; collapse choice to the correct branch
                     case Bool -> WeightedPSQ [Weight] Bool (Tree d c) -> Maybe (Tree d c)
forall k w v. Eq k => k -> WeightedPSQ w k v -> Maybe v
W.lookup Bool
rb WeightedPSQ [Weight] Bool (Tree d c)
ts of
                       Just Tree d c
t  -> QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS QSN
qsn Bool
rb (Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go Tree d c
t)
                       Maybe (Tree d c)
Nothing -> Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail (Var QPN -> ConflictSet
varToConflictSet (QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn)) (QSN -> FailReason
MalformedStanzaChoice QSN
qsn)
          Maybe Bool
Nothing -> -- stanza choice is new, follow both branches
                     QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
SChoice QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
b (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> Validate (WeightedPSQ [Weight] Bool (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Validate (WeightedPSQ [Weight] Bool (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (\Bool
k -> QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS QSN
qsn Bool
k (Validate (Tree d c) -> Validate (Tree d c))
-> (Tree d c -> Validate (Tree d c))
-> Tree d c
-> Validate (Tree d c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go) WeightedPSQ [Weight] Bool (Tree d c)
ts

    -- We don't need to do anything for goal choices or failure nodes.
    go (GoalChoice RevDepMap
rdm           PSQ (Goal QPN) (Tree d c)
ts) = RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
forall d c. RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
GoalChoice RevDepMap
rdm (PSQ (Goal QPN) (Tree d c) -> Tree d c)
-> Validate (PSQ (Goal QPN) (Tree d c)) -> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree d c -> Validate (Tree d c))
-> PSQ (Goal QPN) (Tree d c)
-> Validate (PSQ (Goal QPN) (Tree d c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go PSQ (Goal QPN) (Tree d c)
ts
    go (Done       RevDepMap
rdm d
s           ) = Tree d c -> Validate (Tree d c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RevDepMap -> d -> Tree d c
forall d c. RevDepMap -> d -> Tree d c
Done RevDepMap
rdm d
s)
    go (Fail    ConflictSet
c FailReason
fr               ) = Tree d c -> Validate (Tree d c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c FailReason
fr)

    -- What to do for package nodes ...
    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) (POption I
i Maybe PackagePath
_) Validate (Tree d c)
r = do
      PA PPreAssignment
ppa FAssignment
pfa SAssignment
psa <- (ValidateState -> PreAssignment) -> Validate PreAssignment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PreAssignment
pa    -- obtain current preassignment
      Extension -> Bool
extSupported   <- (ValidateState -> Extension -> Bool)
-> Validate (Extension -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Extension -> Bool
supportedExt  -- obtain the supported extensions
      Language -> Bool
langSupported  <- (ValidateState -> Language -> Bool) -> Validate (Language -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Language -> Bool
supportedLang -- obtain the supported languages
      PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent     <- (ValidateState -> PkgconfigName -> PkgconfigVersionRange -> Bool)
-> Validate (PkgconfigName -> PkgconfigVersionRange -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PkgconfigName -> PkgconfigVersionRange -> Bool
presentPkgs -- obtain the present pkg-config pkgs
      Index
idx            <- (ValidateState -> Index) -> Validate Index
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Index
index -- obtain the index
      Map QPN (FlaggedDeps QPN)
svd            <- (ValidateState -> Map QPN (FlaggedDeps QPN))
-> Validate (Map QPN (FlaggedDeps QPN))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN (FlaggedDeps QPN)
saved -- obtain saved dependencies
      Map QPN (Map ExposedComponent ComponentInfo)
aComps         <- (ValidateState -> Map QPN (Map ExposedComponent ComponentInfo))
-> Validate (Map QPN (Map ExposedComponent ComponentInfo))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN (Map ExposedComponent ComponentInfo)
availableComponents
      Map QPN ComponentDependencyReasons
rComps         <- (ValidateState -> Map QPN ComponentDependencyReasons)
-> Validate (Map QPN ComponentDependencyReasons)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN ComponentDependencyReasons
requiredComponents
      QualifyOptions
qo             <- (ValidateState -> QualifyOptions) -> Validate QualifyOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> QualifyOptions
qualifyOptions
      -- obtain dependencies and index-dictated exclusions introduced by the choice
      let (PInfo FlaggedDeps PackageName
deps Map ExposedComponent ComponentInfo
comps FlagInfo
_ Maybe FailReason
mfr) = Index
idx Index -> PackageName -> Map I PInfo
forall k a. Ord k => Map k a -> k -> a
! PackageName
pn Map I PInfo -> I -> PInfo
forall k a. Ord k => Map k a -> k -> a
! I
i
      -- qualify the deps in the current scope
      let qdeps :: FlaggedDeps QPN
qdeps = QualifyOptions -> QPN -> FlaggedDeps PackageName -> FlaggedDeps QPN
qualifyDeps QualifyOptions
qo QPN
qpn FlaggedDeps PackageName
deps
      -- the new active constraints are given by the instance we have chosen,
      -- plus the dependency information we have for that instance
      let newactives :: [LDep QPN]
newactives = FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
pfa SAssignment
psa FlaggedDeps QPN
qdeps
      -- We now try to extend the partial assignment with the new active constraints.
      let mnppa :: Either Conflict PPreAssignment
mnppa = (Extension -> Bool)
-> (Language -> Bool)
-> (PkgconfigName -> PkgconfigVersionRange -> Bool)
-> [LDep QPN]
-> PPreAssignment
-> Either Conflict PPreAssignment
extend Extension -> Bool
extSupported Language -> Bool
langSupported PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent [LDep QPN]
newactives
                   (PPreAssignment -> Either Conflict PPreAssignment)
-> Either Conflict PPreAssignment -> Either Conflict PPreAssignment
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PI QPN -> PPreAssignment -> Either Conflict PPreAssignment
extendWithPackageChoice (QPN -> I -> PI QPN
forall qpn. qpn -> I -> PI qpn
PI QPN
qpn I
i) PPreAssignment
ppa
      -- In case we continue, we save the scoped dependencies
      let nsvd :: Map QPN (FlaggedDeps QPN)
nsvd = QPN
-> FlaggedDeps QPN
-> Map QPN (FlaggedDeps QPN)
-> Map QPN (FlaggedDeps QPN)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QPN
qpn FlaggedDeps QPN
qdeps Map QPN (FlaggedDeps QPN)
svd
      case Maybe FailReason
mfr of
        Just FailReason
fr -> -- The index marks this as an invalid choice. We can stop.
                   Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail (Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn)) FailReason
fr)
        Maybe FailReason
Nothing ->
          let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
              newDeps :: Either
  Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
newDeps = do
                PPreAssignment
nppa <- Either Conflict PPreAssignment
mnppa
                Map QPN ComponentDependencyReasons
rComps' <- QPN
-> Map QPN (Map ExposedComponent ComponentInfo)
-> Map QPN ComponentDependencyReasons
-> [LDep QPN]
-> Either Conflict (Map QPN ComponentDependencyReasons)
extendRequiredComponents QPN
qpn Map QPN (Map ExposedComponent ComponentInfo)
aComps Map QPN ComponentDependencyReasons
rComps [LDep QPN]
newactives
                ComponentDependencyReasons
-> QPN -> Map ExposedComponent ComponentInfo -> Either Conflict ()
checkComponentsInNewPackage (ComponentDependencyReasons
-> QPN
-> Map QPN ComponentDependencyReasons
-> ComponentDependencyReasons
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ComponentDependencyReasons
forall k a. Map k a
M.empty QPN
qpn Map QPN ComponentDependencyReasons
rComps) QPN
qpn Map ExposedComponent ComponentInfo
comps
                (PPreAssignment, Map QPN ComponentDependencyReasons)
-> Either
     Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
forall (m :: * -> *) a. Monad m => a -> m a
return (PPreAssignment
nppa, Map QPN ComponentDependencyReasons
rComps')
          in case Either
  Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
newDeps of
               Left (ConflictSet
c, FailReason
fr)          -> -- We have an inconsistency. We can stop.
                                        Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c FailReason
fr)
               Right (PPreAssignment
nppa, Map QPN ComponentDependencyReasons
rComps') -> -- We have an updated partial assignment for the recursive validation.
                                        (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ ValidateState
s -> ValidateState
s { pa :: PreAssignment
pa = PPreAssignment -> FAssignment -> SAssignment -> PreAssignment
PA PPreAssignment
nppa FAssignment
pfa SAssignment
psa
                                                        , saved :: Map QPN (FlaggedDeps QPN)
saved = Map QPN (FlaggedDeps QPN)
nsvd
                                                        , availableComponents :: Map QPN (Map ExposedComponent ComponentInfo)
availableComponents = QPN
-> Map ExposedComponent ComponentInfo
-> Map QPN (Map ExposedComponent ComponentInfo)
-> Map QPN (Map ExposedComponent ComponentInfo)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QPN
qpn Map ExposedComponent ComponentInfo
comps Map QPN (Map ExposedComponent ComponentInfo)
aComps
                                                        , requiredComponents :: Map QPN ComponentDependencyReasons
requiredComponents = Map QPN ComponentDependencyReasons
rComps'
                                                        }) Validate (Tree d c)
r

    -- What to do for flag nodes ...
    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF qfn :: QFN
qfn@(FN QPN
qpn Flag
_f) Bool
b Validate (Tree d c)
r = do
      PA PPreAssignment
ppa FAssignment
pfa SAssignment
psa <- (ValidateState -> PreAssignment) -> Validate PreAssignment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PreAssignment
pa -- obtain current preassignment
      Extension -> Bool
extSupported   <- (ValidateState -> Extension -> Bool)
-> Validate (Extension -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Extension -> Bool
supportedExt  -- obtain the supported extensions
      Language -> Bool
langSupported  <- (ValidateState -> Language -> Bool) -> Validate (Language -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Language -> Bool
supportedLang -- obtain the supported languages
      PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent     <- (ValidateState -> PkgconfigName -> PkgconfigVersionRange -> Bool)
-> Validate (PkgconfigName -> PkgconfigVersionRange -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PkgconfigName -> PkgconfigVersionRange -> Bool
presentPkgs   -- obtain the present pkg-config pkgs
      Map QPN (FlaggedDeps QPN)
svd            <- (ValidateState -> Map QPN (FlaggedDeps QPN))
-> Validate (Map QPN (FlaggedDeps QPN))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN (FlaggedDeps QPN)
saved         -- obtain saved dependencies
      Map QPN (Map ExposedComponent ComponentInfo)
aComps         <- (ValidateState -> Map QPN (Map ExposedComponent ComponentInfo))
-> Validate (Map QPN (Map ExposedComponent ComponentInfo))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN (Map ExposedComponent ComponentInfo)
availableComponents
      Map QPN ComponentDependencyReasons
rComps         <- (ValidateState -> Map QPN ComponentDependencyReasons)
-> Validate (Map QPN ComponentDependencyReasons)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN ComponentDependencyReasons
requiredComponents
      -- Note that there should be saved dependencies for the package in question,
      -- because while building, we do not choose flags before we see the packages
      -- that define them.
      let qdeps :: FlaggedDeps QPN
qdeps = Map QPN (FlaggedDeps QPN)
svd Map QPN (FlaggedDeps QPN) -> QPN -> FlaggedDeps QPN
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn
      -- We take the *saved* dependencies, because these have been qualified in the
      -- correct scope.
      --
      -- Extend the flag assignment
      let npfa :: FAssignment
npfa = QFN -> Bool -> FAssignment -> FAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QFN
qfn Bool
b FAssignment
pfa
      -- We now try to get the new active dependencies we might learn about because
      -- we have chosen a new flag.
      let newactives :: [LDep QPN]
newactives = Var QPN
-> Bool
-> FAssignment
-> SAssignment
-> FlaggedDeps QPN
-> [LDep QPN]
extractNewDeps (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn) Bool
b FAssignment
npfa SAssignment
psa FlaggedDeps QPN
qdeps
          mNewRequiredComps :: Either Conflict (Map QPN ComponentDependencyReasons)
mNewRequiredComps = QPN
-> Map QPN (Map ExposedComponent ComponentInfo)
-> Map QPN ComponentDependencyReasons
-> [LDep QPN]
-> Either Conflict (Map QPN ComponentDependencyReasons)
extendRequiredComponents QPN
qpn Map QPN (Map ExposedComponent ComponentInfo)
aComps Map QPN ComponentDependencyReasons
rComps [LDep QPN]
newactives
      -- As in the package case, we try to extend the partial assignment.
      let mnppa :: Either Conflict PPreAssignment
mnppa = (Extension -> Bool)
-> (Language -> Bool)
-> (PkgconfigName -> PkgconfigVersionRange -> Bool)
-> [LDep QPN]
-> PPreAssignment
-> Either Conflict PPreAssignment
extend Extension -> Bool
extSupported Language -> Bool
langSupported PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent [LDep QPN]
newactives PPreAssignment
ppa
      case (PPreAssignment
 -> Map QPN ComponentDependencyReasons
 -> (PPreAssignment, Map QPN ComponentDependencyReasons))
-> Either Conflict PPreAssignment
-> Either Conflict (Map QPN ComponentDependencyReasons)
-> Either
     Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Either Conflict PPreAssignment
mnppa Either Conflict (Map QPN ComponentDependencyReasons)
mNewRequiredComps of
        Left (ConflictSet
c, FailReason
fr)         -> Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c FailReason
fr) -- inconsistency found
        Right (PPreAssignment
nppa, Map QPN ComponentDependencyReasons
rComps') ->
            (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ ValidateState
s -> ValidateState
s { pa :: PreAssignment
pa = PPreAssignment -> FAssignment -> SAssignment -> PreAssignment
PA PPreAssignment
nppa FAssignment
npfa SAssignment
psa, requiredComponents :: Map QPN ComponentDependencyReasons
requiredComponents = Map QPN ComponentDependencyReasons
rComps' }) Validate (Tree d c)
r

    -- What to do for stanza nodes (similar to flag nodes) ...
    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS qsn :: QSN
qsn@(SN QPN
qpn Stanza
_f) Bool
b Validate (Tree d c)
r = do
      PA PPreAssignment
ppa FAssignment
pfa SAssignment
psa <- (ValidateState -> PreAssignment) -> Validate PreAssignment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PreAssignment
pa -- obtain current preassignment
      Extension -> Bool
extSupported   <- (ValidateState -> Extension -> Bool)
-> Validate (Extension -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Extension -> Bool
supportedExt  -- obtain the supported extensions
      Language -> Bool
langSupported  <- (ValidateState -> Language -> Bool) -> Validate (Language -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Language -> Bool
supportedLang -- obtain the supported languages
      PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent     <- (ValidateState -> PkgconfigName -> PkgconfigVersionRange -> Bool)
-> Validate (PkgconfigName -> PkgconfigVersionRange -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> PkgconfigName -> PkgconfigVersionRange -> Bool
presentPkgs -- obtain the present pkg-config pkgs
      Map QPN (FlaggedDeps QPN)
svd            <- (ValidateState -> Map QPN (FlaggedDeps QPN))
-> Validate (Map QPN (FlaggedDeps QPN))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN (FlaggedDeps QPN)
saved         -- obtain saved dependencies
      Map QPN (Map ExposedComponent ComponentInfo)
aComps         <- (ValidateState -> Map QPN (Map ExposedComponent ComponentInfo))
-> Validate (Map QPN (Map ExposedComponent ComponentInfo))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN (Map ExposedComponent ComponentInfo)
availableComponents
      Map QPN ComponentDependencyReasons
rComps         <- (ValidateState -> Map QPN ComponentDependencyReasons)
-> Validate (Map QPN ComponentDependencyReasons)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidateState -> Map QPN ComponentDependencyReasons
requiredComponents
      -- Note that there should be saved dependencies for the package in question,
      -- because while building, we do not choose flags before we see the packages
      -- that define them.
      let qdeps :: FlaggedDeps QPN
qdeps = Map QPN (FlaggedDeps QPN)
svd Map QPN (FlaggedDeps QPN) -> QPN -> FlaggedDeps QPN
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn
      -- We take the *saved* dependencies, because these have been qualified in the
      -- correct scope.
      --
      -- Extend the flag assignment
      let npsa :: SAssignment
npsa = QSN -> Bool -> SAssignment -> SAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QSN
qsn Bool
b SAssignment
psa
      -- We now try to get the new active dependencies we might learn about because
      -- we have chosen a new flag.
      let newactives :: [LDep QPN]
newactives = Var QPN
-> Bool
-> FAssignment
-> SAssignment
-> FlaggedDeps QPN
-> [LDep QPN]
extractNewDeps (QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn) Bool
b FAssignment
pfa SAssignment
npsa FlaggedDeps QPN
qdeps
          mNewRequiredComps :: Either Conflict (Map QPN ComponentDependencyReasons)
mNewRequiredComps = QPN
-> Map QPN (Map ExposedComponent ComponentInfo)
-> Map QPN ComponentDependencyReasons
-> [LDep QPN]
-> Either Conflict (Map QPN ComponentDependencyReasons)
extendRequiredComponents QPN
qpn Map QPN (Map ExposedComponent ComponentInfo)
aComps Map QPN ComponentDependencyReasons
rComps [LDep QPN]
newactives
      -- As in the package case, we try to extend the partial assignment.
      let mnppa :: Either Conflict PPreAssignment
mnppa = (Extension -> Bool)
-> (Language -> Bool)
-> (PkgconfigName -> PkgconfigVersionRange -> Bool)
-> [LDep QPN]
-> PPreAssignment
-> Either Conflict PPreAssignment
extend Extension -> Bool
extSupported Language -> Bool
langSupported PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent [LDep QPN]
newactives PPreAssignment
ppa
      case (PPreAssignment
 -> Map QPN ComponentDependencyReasons
 -> (PPreAssignment, Map QPN ComponentDependencyReasons))
-> Either Conflict PPreAssignment
-> Either Conflict (Map QPN ComponentDependencyReasons)
-> Either
     Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Either Conflict PPreAssignment
mnppa Either Conflict (Map QPN ComponentDependencyReasons)
mNewRequiredComps of
        Left (ConflictSet
c, FailReason
fr)         -> Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c FailReason
fr) -- inconsistency found
        Right (PPreAssignment
nppa, Map QPN ComponentDependencyReasons
rComps') ->
            (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ ValidateState
s -> ValidateState
s { pa :: PreAssignment
pa = PPreAssignment -> FAssignment -> SAssignment -> PreAssignment
PA PPreAssignment
nppa FAssignment
pfa SAssignment
npsa, requiredComponents :: Map QPN ComponentDependencyReasons
requiredComponents = Map QPN ComponentDependencyReasons
rComps' }) Validate (Tree d c)
r

-- | Check that a newly chosen package instance contains all components that
-- are required from that package so far. The components must also be visible
-- and buildable.
checkComponentsInNewPackage :: ComponentDependencyReasons
                            -> QPN
                            -> Map ExposedComponent ComponentInfo
                            -> Either Conflict ()
checkComponentsInNewPackage :: ComponentDependencyReasons
-> QPN -> Map ExposedComponent ComponentInfo -> Either Conflict ()
checkComponentsInNewPackage ComponentDependencyReasons
required QPN
qpn Map ExposedComponent ComponentInfo
providedComps =
    case ComponentDependencyReasons
-> [(ExposedComponent, DependencyReason QPN)]
forall k a. Map k a -> [(k, a)]
M.toList (ComponentDependencyReasons
 -> [(ExposedComponent, DependencyReason QPN)])
-> ComponentDependencyReasons
-> [(ExposedComponent, DependencyReason QPN)]
forall a b. (a -> b) -> a -> b
$ [ExposedComponent]
-> ComponentDependencyReasons -> ComponentDependencyReasons
forall k v. Ord k => [k] -> Map k v -> Map k v
deleteKeys (Map ExposedComponent ComponentInfo -> [ExposedComponent]
forall k a. Map k a -> [k]
M.keys Map ExposedComponent ComponentInfo
providedComps) ComponentDependencyReasons
required of
      (ExposedComponent
missingComp, DependencyReason QPN
dr) : [(ExposedComponent, DependencyReason QPN)]
_ ->
          Conflict -> Either Conflict ()
forall a b. a -> Either a b
Left (Conflict -> Either Conflict ()) -> Conflict -> Either Conflict ()
forall a b. (a -> b) -> a -> b
$ ExposedComponent
-> DependencyReason QPN
-> (ExposedComponent -> DependencyReason QPN -> FailReason)
-> Conflict
mkConflict ExposedComponent
missingComp DependencyReason QPN
dr ExposedComponent -> DependencyReason QPN -> FailReason
NewPackageIsMissingRequiredComponent
      []                    ->
          let failures :: [Conflict]
failures = [Either Conflict ()] -> [Conflict]
forall a b. [Either a b] -> [a]
lefts
                  [ case () of
                      ()
_ | ComponentInfo -> IsVisible
compIsVisible ComponentInfo
compInfo IsVisible -> IsVisible -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsVisible
IsVisible Bool
False ->
                          Conflict -> Either Conflict ()
forall a b. a -> Either a b
Left (Conflict -> Either Conflict ()) -> Conflict -> Either Conflict ()
forall a b. (a -> b) -> a -> b
$ ExposedComponent
-> DependencyReason QPN
-> (ExposedComponent -> DependencyReason QPN -> FailReason)
-> Conflict
mkConflict ExposedComponent
comp DependencyReason QPN
dr ExposedComponent -> DependencyReason QPN -> FailReason
NewPackageHasPrivateRequiredComponent
                        | ComponentInfo -> IsBuildable
compIsBuildable ComponentInfo
compInfo IsBuildable -> IsBuildable -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsBuildable
IsBuildable Bool
False ->
                          Conflict -> Either Conflict ()
forall a b. a -> Either a b
Left (Conflict -> Either Conflict ()) -> Conflict -> Either Conflict ()
forall a b. (a -> b) -> a -> b
$ ExposedComponent
-> DependencyReason QPN
-> (ExposedComponent -> DependencyReason QPN -> FailReason)
-> Conflict
mkConflict ExposedComponent
comp DependencyReason QPN
dr ExposedComponent -> DependencyReason QPN -> FailReason
NewPackageHasUnbuildableRequiredComponent
                        | Bool
otherwise -> () -> Either Conflict ()
forall a b. b -> Either a b
Right ()
                  | let merged :: Map ExposedComponent (DependencyReason QPN, ComponentInfo)
merged = (DependencyReason QPN
 -> ComponentInfo -> (DependencyReason QPN, ComponentInfo))
-> ComponentDependencyReasons
-> Map ExposedComponent ComponentInfo
-> Map ExposedComponent (DependencyReason QPN, ComponentInfo)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (,) ComponentDependencyReasons
required Map ExposedComponent ComponentInfo
providedComps
                  , (ExposedComponent
comp, (DependencyReason QPN
dr, ComponentInfo
compInfo)) <- Map ExposedComponent (DependencyReason QPN, ComponentInfo)
-> [(ExposedComponent, (DependencyReason QPN, ComponentInfo))]
forall k a. Map k a -> [(k, a)]
M.toList Map ExposedComponent (DependencyReason QPN, ComponentInfo)
merged ]
          in case [Conflict]
failures of
               Conflict
failure : [Conflict]
_ -> Conflict -> Either Conflict ()
forall a b. a -> Either a b
Left Conflict
failure
               []          -> () -> Either Conflict ()
forall a b. b -> Either a b
Right ()
  where
    mkConflict :: ExposedComponent
               -> DependencyReason QPN
               -> (ExposedComponent -> DependencyReason QPN -> FailReason)
               -> Conflict
    mkConflict :: ExposedComponent
-> DependencyReason QPN
-> (ExposedComponent -> DependencyReason QPN -> FailReason)
-> Conflict
mkConflict ExposedComponent
comp DependencyReason QPN
dr ExposedComponent -> DependencyReason QPN -> FailReason
mkFailure =
        (Var QPN -> ConflictSet -> ConflictSet
CS.insert (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn) (DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet DependencyReason QPN
dr), ExposedComponent -> DependencyReason QPN -> FailReason
mkFailure ExposedComponent
comp DependencyReason QPN
dr)

    deleteKeys :: Ord k => [k] -> Map k v -> Map k v
    deleteKeys :: [k] -> Map k v -> Map k v
deleteKeys [k]
ks Map k v
m = (k -> Map k v -> Map k v) -> Map k v -> [k] -> Map k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr k -> Map k v -> Map k v
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Map k v
m [k]
ks

-- | We try to extract as many concrete dependencies from the given flagged
-- dependencies as possible. We make use of all the flag knowledge we have
-- already acquired.
extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
fa SAssignment
sa FlaggedDeps QPN
deps = do
  FlaggedDep QPN
d <- FlaggedDeps QPN
deps
  case FlaggedDep QPN
d of
    Simple LDep QPN
sd Component
_         -> LDep QPN -> [LDep QPN]
forall (m :: * -> *) a. Monad m => a -> m a
return LDep QPN
sd
    Flagged QFN
qfn FInfo
_ FlaggedDeps QPN
td FlaggedDeps QPN
fd -> case QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QFN
qfn FAssignment
fa of
                             Maybe Bool
Nothing    -> [LDep QPN]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                             Just Bool
True  -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
fa SAssignment
sa FlaggedDeps QPN
td
                             Just Bool
False -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
fa SAssignment
sa FlaggedDeps QPN
fd
    Stanza QSN
qsn FlaggedDeps QPN
td       -> case QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QSN
qsn SAssignment
sa of
                             Maybe Bool
Nothing    -> [LDep QPN]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                             Just Bool
True  -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
fa SAssignment
sa FlaggedDeps QPN
td
                             Just Bool
False -> []

-- | We try to find new dependencies that become available due to the given
-- flag or stanza choice. We therefore look for the choice in question, and then call
-- 'extractAllDeps' for everything underneath.
extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractNewDeps :: Var QPN
-> Bool
-> FAssignment
-> SAssignment
-> FlaggedDeps QPN
-> [LDep QPN]
extractNewDeps Var QPN
v Bool
b FAssignment
fa SAssignment
sa = FlaggedDeps QPN -> [LDep QPN]
go
  where
    go :: FlaggedDeps QPN -> [LDep QPN]
    go :: FlaggedDeps QPN -> [LDep QPN]
go FlaggedDeps QPN
deps = do
      FlaggedDep QPN
d <- FlaggedDeps QPN
deps
      case FlaggedDep QPN
d of
        Simple LDep QPN
_ Component
_           -> [LDep QPN]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Flagged QFN
qfn' FInfo
_ FlaggedDeps QPN
td FlaggedDeps QPN
fd
          | Var QPN
v Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn'      -> if Bool
b then FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
fa SAssignment
sa FlaggedDeps QPN
td else FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
fa SAssignment
sa FlaggedDeps QPN
fd
          | Bool
otherwise        -> case QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QFN
qfn' FAssignment
fa of
                                  Maybe Bool
Nothing    -> [LDep QPN]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                                  Just Bool
True  -> FlaggedDeps QPN -> [LDep QPN]
go FlaggedDeps QPN
td
                                  Just Bool
False -> FlaggedDeps QPN -> [LDep QPN]
go FlaggedDeps QPN
fd
        Stanza QSN
qsn' FlaggedDeps QPN
td
          | Var QPN
v Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn'      -> if Bool
b then FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
extractAllDeps FAssignment
fa SAssignment
sa FlaggedDeps QPN
td else []
          | Bool
otherwise        -> case QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QSN
qsn' SAssignment
sa of
                                  Maybe Bool
Nothing    -> [LDep QPN]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                                  Just Bool
True  -> FlaggedDeps QPN -> [LDep QPN]
go FlaggedDeps QPN
td
                                  Just Bool
False -> []

-- | Extend a package preassignment.
--
-- Takes the variable that causes the new constraints, a current preassignment
-- and a set of new dependency constraints.
--
-- We're trying to extend the preassignment with each dependency one by one.
-- Each dependency is for a particular variable. We check if we already have
-- constraints for that variable in the current preassignment. If so, we're
-- trying to merge the constraints.
--
-- Either returns a witness of the conflict that would arise during the merge,
-- or the successfully extended assignment.
extend :: (Extension -> Bool)            -- ^ is a given extension supported
       -> (Language  -> Bool)            -- ^ is a given language supported
       -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable
       -> [LDep QPN]
       -> PPreAssignment
       -> Either Conflict PPreAssignment
extend :: (Extension -> Bool)
-> (Language -> Bool)
-> (PkgconfigName -> PkgconfigVersionRange -> Bool)
-> [LDep QPN]
-> PPreAssignment
-> Either Conflict PPreAssignment
extend Extension -> Bool
extSupported Language -> Bool
langSupported PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent [LDep QPN]
newactives PPreAssignment
ppa = (PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment)
-> PPreAssignment -> [LDep QPN] -> Either Conflict PPreAssignment
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment
extendSingle PPreAssignment
ppa [LDep QPN]
newactives
  where

    extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment
    extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment
extendSingle PPreAssignment
a (LDep DependencyReason QPN
dr (Ext  Extension
ext ))  =
      if Extension -> Bool
extSupported  Extension
ext  then PPreAssignment -> Either Conflict PPreAssignment
forall a b. b -> Either a b
Right PPreAssignment
a
                            else Conflict -> Either Conflict PPreAssignment
forall a b. a -> Either a b
Left (DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet DependencyReason QPN
dr, Extension -> FailReason
UnsupportedExtension Extension
ext)
    extendSingle PPreAssignment
a (LDep DependencyReason QPN
dr (Lang Language
lang))  =
      if Language -> Bool
langSupported Language
lang then PPreAssignment -> Either Conflict PPreAssignment
forall a b. b -> Either a b
Right PPreAssignment
a
                            else Conflict -> Either Conflict PPreAssignment
forall a b. a -> Either a b
Left (DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet DependencyReason QPN
dr, Language -> FailReason
UnsupportedLanguage Language
lang)
    extendSingle PPreAssignment
a (LDep DependencyReason QPN
dr (Pkg PkgconfigName
pn PkgconfigVersionRange
vr))  =
      if PkgconfigName -> PkgconfigVersionRange -> Bool
pkgPresent PkgconfigName
pn PkgconfigVersionRange
vr then PPreAssignment -> Either Conflict PPreAssignment
forall a b. b -> Either a b
Right PPreAssignment
a
                          else Conflict -> Either Conflict PPreAssignment
forall a b. a -> Either a b
Left (DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet DependencyReason QPN
dr, PkgconfigName -> PkgconfigVersionRange -> FailReason
MissingPkgconfigPackage PkgconfigName
pn PkgconfigVersionRange
vr)
    extendSingle PPreAssignment
a (LDep DependencyReason QPN
dr (Dep dep :: PkgComponent QPN
dep@(PkgComponent QPN
qpn ExposedComponent
_) CI
ci)) =
      let mergedDep :: MergedPkgDep
mergedDep = MergedPkgDep -> QPN -> PPreAssignment -> MergedPkgDep
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([VROrigin] -> MergedPkgDep
MergedDepConstrained []) QPN
qpn PPreAssignment
a
      in  case (\ MergedPkgDep
x -> QPN -> MergedPkgDep -> PPreAssignment -> PPreAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QPN
qpn MergedPkgDep
x PPreAssignment
a) (MergedPkgDep -> PPreAssignment)
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) PPreAssignment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergedPkgDep
-> PkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge MergedPkgDep
mergedDep (DependencyReason QPN -> PkgComponent QPN -> CI -> PkgDep
PkgDep DependencyReason QPN
dr PkgComponent QPN
dep CI
ci) of
            Left (ConflictSet
c, (ConflictingDep
d, ConflictingDep
d')) -> Conflict -> Either Conflict PPreAssignment
forall a b. a -> Either a b
Left (ConflictSet
c, ConflictingDep -> ConflictingDep -> FailReason
ConflictingConstraints ConflictingDep
d ConflictingDep
d')
            Right PPreAssignment
x           -> PPreAssignment -> Either Conflict PPreAssignment
forall a b. b -> Either a b
Right PPreAssignment
x

-- | Extend a package preassignment with a package choice. For example, when
-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0.
--
-- TODO: The new constraint is implemented as a dependency from foo to foo's
-- main library. That isn't correct, because foo might only be needed as a build
-- tool dependency. The implementation may need to change when we support
-- component-based dependency solving.
extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment
extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment
extendWithPackageChoice (PI QPN
qpn I
i) PPreAssignment
ppa =
  let mergedDep :: MergedPkgDep
mergedDep = MergedPkgDep -> QPN -> PPreAssignment -> MergedPkgDep
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([VROrigin] -> MergedPkgDep
MergedDepConstrained []) QPN
qpn PPreAssignment
ppa
      newChoice :: PkgDep
newChoice = DependencyReason QPN -> PkgComponent QPN -> CI -> PkgDep
PkgDep (QPN -> Map Flag FlagValue -> Set Stanza -> DependencyReason QPN
forall qpn.
qpn -> Map Flag FlagValue -> Set Stanza -> DependencyReason qpn
DependencyReason QPN
qpn Map Flag FlagValue
forall k a. Map k a
M.empty Set Stanza
forall a. Set a
S.empty)
                         (QPN -> ExposedComponent -> PkgComponent QPN
forall qpn. qpn -> ExposedComponent -> PkgComponent qpn
PkgComponent QPN
qpn (LibraryName -> ExposedComponent
ExposedLib LibraryName
LMainLibName))
                         (I -> CI
Fixed I
i)
  in  case (\ MergedPkgDep
x -> QPN -> MergedPkgDep -> PPreAssignment -> PPreAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QPN
qpn MergedPkgDep
x PPreAssignment
ppa) (MergedPkgDep -> PPreAssignment)
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) PPreAssignment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergedPkgDep
-> PkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge MergedPkgDep
mergedDep PkgDep
newChoice of
        Left (ConflictSet
c, (ConflictingDep
d, ConflictingDep
_d')) -> -- Don't include the package choice in the
                              -- FailReason, because it is redundant.
                              Conflict -> Either Conflict PPreAssignment
forall a b. a -> Either a b
Left (ConflictSet
c, ConflictingDep -> FailReason
NewPackageDoesNotMatchExistingConstraint ConflictingDep
d)
        Right PPreAssignment
x            -> PPreAssignment -> Either Conflict PPreAssignment
forall a b. b -> Either a b
Right PPreAssignment
x

-- | Merge constrained instances. We currently adopt a lazy strategy for
-- merging, i.e., we only perform actual checking if one of the two choices
-- is fixed. If the merge fails, we return a conflict set indicating the
-- variables responsible for the failure, as well as the two conflicting
-- fragments.
--
-- Note that while there may be more than one conflicting pair of version
-- ranges, we only return the first we find.
--
-- The ConflictingDeps are returned in order, i.e., the first describes the
-- conflicting part of the MergedPkgDep, and the second describes the PkgDep.
--
-- TODO: Different pairs might have different conflict sets. We're
-- obviously interested to return a conflict that has a "better" conflict
-- set in the sense the it contains variables that allow us to backjump
-- further. We might apply some heuristics here, such as to change the
-- order in which we check the constraints.
merge ::
#ifdef DEBUG_CONFLICT_SETS
  (?loc :: CallStack) =>
#endif
  MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge :: MergedPkgDep
-> PkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge (MergedDepFixed ExposedComponent
comp1 DependencyReason QPN
vs1 I
i1) (PkgDep DependencyReason QPN
vs2 (PkgComponent QPN
p ExposedComponent
comp2) ci :: CI
ci@(Fixed I
i2))
  | I
i1 I -> I -> Bool
forall a. Eq a => a -> a -> Bool
== I
i2  = MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. b -> Either a b
Right (MergedPkgDep
 -> Either
      (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep)
-> MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. (a -> b) -> a -> b
$ ExposedComponent -> DependencyReason QPN -> I -> MergedPkgDep
MergedDepFixed ExposedComponent
comp1 DependencyReason QPN
vs1 I
i1
  | Bool
otherwise =
      (ConflictSet, (ConflictingDep, ConflictingDep))
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. a -> Either a b
Left ( (ConflictSet -> ConflictSet -> ConflictSet
CS.union (ConflictSet -> ConflictSet -> ConflictSet)
-> (DependencyReason QPN -> ConflictSet)
-> DependencyReason QPN
-> DependencyReason QPN
-> ConflictSet
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet) DependencyReason QPN
vs1 DependencyReason QPN
vs2
           , ( DependencyReason QPN -> PkgComponent QPN -> CI -> ConflictingDep
ConflictingDep DependencyReason QPN
vs1 (QPN -> ExposedComponent -> PkgComponent QPN
forall qpn. qpn -> ExposedComponent -> PkgComponent qpn
PkgComponent QPN
p ExposedComponent
comp1) (I -> CI
Fixed I
i1)
             , DependencyReason QPN -> PkgComponent QPN -> CI -> ConflictingDep
ConflictingDep DependencyReason QPN
vs2 (QPN -> ExposedComponent -> PkgComponent QPN
forall qpn. qpn -> ExposedComponent -> PkgComponent qpn
PkgComponent QPN
p ExposedComponent
comp2) CI
ci ) )

merge (MergedDepFixed ExposedComponent
comp1 DependencyReason QPN
vs1 i :: I
i@(I Ver
v Loc
_)) (PkgDep DependencyReason QPN
vs2 (PkgComponent QPN
p ExposedComponent
comp2) ci :: CI
ci@(Constrained VR
vr))
  | VR -> Ver -> Bool
checkVR VR
vr Ver
v = MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. b -> Either a b
Right (MergedPkgDep
 -> Either
      (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep)
-> MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. (a -> b) -> a -> b
$ ExposedComponent -> DependencyReason QPN -> I -> MergedPkgDep
MergedDepFixed ExposedComponent
comp1 DependencyReason QPN
vs1 I
i
  | Bool
otherwise    =
      (ConflictSet, (ConflictingDep, ConflictingDep))
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. a -> Either a b
Left ( QPN
-> Ver
-> DependencyReason QPN
-> VR
-> DependencyReason QPN
-> ConflictSet
createConflictSetForVersionConflict QPN
p Ver
v DependencyReason QPN
vs1 VR
vr DependencyReason QPN
vs2
           , ( DependencyReason QPN -> PkgComponent QPN -> CI -> ConflictingDep
ConflictingDep DependencyReason QPN
vs1 (QPN -> ExposedComponent -> PkgComponent QPN
forall qpn. qpn -> ExposedComponent -> PkgComponent qpn
PkgComponent QPN
p ExposedComponent
comp1) (I -> CI
Fixed I
i)
             , DependencyReason QPN -> PkgComponent QPN -> CI -> ConflictingDep
ConflictingDep DependencyReason QPN
vs2 (QPN -> ExposedComponent -> PkgComponent QPN
forall qpn. qpn -> ExposedComponent -> PkgComponent qpn
PkgComponent QPN
p ExposedComponent
comp2) CI
ci ) )

merge (MergedDepConstrained [VROrigin]
vrOrigins) (PkgDep DependencyReason QPN
vs2 (PkgComponent QPN
p ExposedComponent
comp2) ci :: CI
ci@(Fixed i :: I
i@(I Ver
v Loc
_))) =
    [VROrigin]
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
go [VROrigin]
vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...
  where
    go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
    go :: [VROrigin]
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
go [] = MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. b -> Either a b
Right (ExposedComponent -> DependencyReason QPN -> I -> MergedPkgDep
MergedDepFixed ExposedComponent
comp2 DependencyReason QPN
vs2 I
i)
    go ((VR
vr, ExposedComponent
comp1, DependencyReason QPN
vs1) : [VROrigin]
vros)
       | VR -> Ver -> Bool
checkVR VR
vr Ver
v = [VROrigin]
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
go [VROrigin]
vros
       | Bool
otherwise    =
           (ConflictSet, (ConflictingDep, ConflictingDep))
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. a -> Either a b
Left ( QPN
-> Ver
-> DependencyReason QPN
-> VR
-> DependencyReason QPN
-> ConflictSet
createConflictSetForVersionConflict QPN
p Ver
v DependencyReason QPN
vs2 VR
vr DependencyReason QPN
vs1
                , ( DependencyReason QPN -> PkgComponent QPN -> CI -> ConflictingDep
ConflictingDep DependencyReason QPN
vs1 (QPN -> ExposedComponent -> PkgComponent QPN
forall qpn. qpn -> ExposedComponent -> PkgComponent qpn
PkgComponent QPN
p ExposedComponent
comp1) (VR -> CI
Constrained VR
vr)
                  , DependencyReason QPN -> PkgComponent QPN -> CI -> ConflictingDep
ConflictingDep DependencyReason QPN
vs2 (QPN -> ExposedComponent -> PkgComponent QPN
forall qpn. qpn -> ExposedComponent -> PkgComponent qpn
PkgComponent QPN
p ExposedComponent
comp2) CI
ci ) )

merge (MergedDepConstrained [VROrigin]
vrOrigins) (PkgDep DependencyReason QPN
vs2 (PkgComponent QPN
_ ExposedComponent
comp2) (Constrained VR
vr)) =
    MergedPkgDep
-> Either
     (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
forall a b. b -> Either a b
Right ([VROrigin] -> MergedPkgDep
MergedDepConstrained ([VROrigin] -> MergedPkgDep) -> [VROrigin] -> MergedPkgDep
forall a b. (a -> b) -> a -> b
$

    -- TODO: This line appends the new version range, to preserve the order used
    -- before a refactoring. Consider prepending the version range, if there is
    -- no negative performance impact.
    [VROrigin]
vrOrigins [VROrigin] -> [VROrigin] -> [VROrigin]
forall a. [a] -> [a] -> [a]
++ [(VR
vr, ExposedComponent
comp2, DependencyReason QPN
vs2)])

-- | Creates a conflict set representing a conflict between a version constraint
-- and the fixed version chosen for a package.
createConflictSetForVersionConflict :: QPN
                                    -> Ver
                                    -> DependencyReason QPN
                                    -> VR
                                    -> DependencyReason QPN
                                    -> ConflictSet
createConflictSetForVersionConflict :: QPN
-> Ver
-> DependencyReason QPN
-> VR
-> DependencyReason QPN
-> ConflictSet
createConflictSetForVersionConflict QPN
pkg
                                    Ver
conflictingVersion
                                    versionDR :: DependencyReason QPN
versionDR@(DependencyReason QPN
p1 Map Flag FlagValue
_ Set Stanza
_)
                                    VR
conflictingVersionRange
                                    versionRangeDR :: DependencyReason QPN
versionRangeDR@(DependencyReason QPN
p2 Map Flag FlagValue
_ Set Stanza
_) =
  let hasFlagsOrStanzas :: DependencyReason qpn -> Bool
hasFlagsOrStanzas (DependencyReason qpn
_ Map Flag FlagValue
fs Set Stanza
ss) = Bool -> Bool
not (Map Flag FlagValue -> Bool
forall k a. Map k a -> Bool
M.null Map Flag FlagValue
fs) Bool -> Bool -> Bool
|| Bool -> Bool
not (Set Stanza -> Bool
forall a. Set a -> Bool
S.null Set Stanza
ss)
  in
    -- The solver currently only optimizes the case where there is a conflict
    -- between the version chosen for a package and a version constraint that
    -- is not under any flags or stanzas. Here is how we check for this case:
    --
    --   (1) Choosing a specific version for a package foo is implemented as
    --       adding a dependency from foo to that version of foo (See
    --       extendWithPackageChoice), so we check that the DependencyReason
    --       contains the current package and no flag or stanza choices.
    --
    --   (2) We check that the DependencyReason for the version constraint also
    --       contains no flag or stanza choices.
    --
    -- When these criteria are not met, we fall back to calling
    -- dependencyReasonToConflictSet.
    if QPN
p1 QPN -> QPN -> Bool
forall a. Eq a => a -> a -> Bool
== QPN
pkg Bool -> Bool -> Bool
&& Bool -> Bool
not (DependencyReason QPN -> Bool
forall qpn. DependencyReason qpn -> Bool
hasFlagsOrStanzas DependencyReason QPN
versionDR) Bool -> Bool -> Bool
&& Bool -> Bool
not (DependencyReason QPN -> Bool
forall qpn. DependencyReason qpn -> Bool
hasFlagsOrStanzas DependencyReason QPN
versionRangeDR)
    then let cs1 :: ConflictSet
cs1 = QPN -> OrderedVersionRange -> DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSetWithVersionConflict
                   QPN
p2
                   (VR -> OrderedVersionRange
CS.OrderedVersionRange VR
conflictingVersionRange)
                   DependencyReason QPN
versionDR
             cs2 :: ConflictSet
cs2 = QPN -> Ver -> DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSetWithVersionConstraintConflict
                   QPN
pkg Ver
conflictingVersion DependencyReason QPN
versionRangeDR
         in ConflictSet
cs1 ConflictSet -> ConflictSet -> ConflictSet
`CS.union` ConflictSet
cs2
    else DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet DependencyReason QPN
versionRangeDR ConflictSet -> ConflictSet -> ConflictSet
`CS.union` DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet DependencyReason QPN
versionDR

-- | 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, private, or unbuildable in a previously
-- chosen package.
extendRequiredComponents :: QPN -- ^ package we extend
                         -> Map QPN (Map ExposedComponent ComponentInfo)
                         -> Map QPN ComponentDependencyReasons
                         -> [LDep QPN]
                         -> Either Conflict (Map QPN ComponentDependencyReasons)
extendRequiredComponents :: QPN
-> Map QPN (Map ExposedComponent ComponentInfo)
-> Map QPN ComponentDependencyReasons
-> [LDep QPN]
-> Either Conflict (Map QPN ComponentDependencyReasons)
extendRequiredComponents QPN
eqpn Map QPN (Map ExposedComponent ComponentInfo)
available = (Map QPN ComponentDependencyReasons
 -> LDep QPN
 -> Either Conflict (Map QPN ComponentDependencyReasons))
-> Map QPN ComponentDependencyReasons
-> [LDep QPN]
-> Either Conflict (Map QPN ComponentDependencyReasons)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map QPN ComponentDependencyReasons
-> LDep QPN -> Either Conflict (Map QPN ComponentDependencyReasons)
extendSingle
  where
    extendSingle :: Map QPN ComponentDependencyReasons
                 -> LDep QPN
                 -> Either Conflict (Map QPN ComponentDependencyReasons)
    extendSingle :: Map QPN ComponentDependencyReasons
-> LDep QPN -> Either Conflict (Map QPN ComponentDependencyReasons)
extendSingle Map QPN ComponentDependencyReasons
required (LDep DependencyReason QPN
dr (Dep (PkgComponent QPN
qpn ExposedComponent
comp) CI
_)) =
      let compDeps :: ComponentDependencyReasons
compDeps = ComponentDependencyReasons
-> QPN
-> Map QPN ComponentDependencyReasons
-> ComponentDependencyReasons
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ComponentDependencyReasons
forall k a. Map k a
M.empty QPN
qpn Map QPN ComponentDependencyReasons
required
          success :: Either a (Map QPN ComponentDependencyReasons)
success = Map QPN ComponentDependencyReasons
-> Either a (Map QPN ComponentDependencyReasons)
forall a b. b -> Either a b
Right (Map QPN ComponentDependencyReasons
 -> Either a (Map QPN ComponentDependencyReasons))
-> Map QPN ComponentDependencyReasons
-> Either a (Map QPN ComponentDependencyReasons)
forall a b. (a -> b) -> a -> b
$ (ComponentDependencyReasons
 -> ComponentDependencyReasons -> ComponentDependencyReasons)
-> QPN
-> ComponentDependencyReasons
-> Map QPN ComponentDependencyReasons
-> Map QPN ComponentDependencyReasons
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ComponentDependencyReasons
-> ComponentDependencyReasons -> ComponentDependencyReasons
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union QPN
qpn (ExposedComponent
-> DependencyReason QPN
-> ComponentDependencyReasons
-> ComponentDependencyReasons
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ExposedComponent
comp DependencyReason QPN
dr ComponentDependencyReasons
compDeps) Map QPN ComponentDependencyReasons
required
      in -- Only check for the existence of the component if its package has
         -- already been chosen.
         case QPN
-> Map QPN (Map ExposedComponent ComponentInfo)
-> Maybe (Map ExposedComponent ComponentInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QPN
qpn Map QPN (Map ExposedComponent ComponentInfo)
available of
           Just Map ExposedComponent ComponentInfo
comps ->
               case ExposedComponent
-> Map ExposedComponent ComponentInfo -> Maybe ComponentInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ExposedComponent
comp Map ExposedComponent ComponentInfo
comps of
                 Maybe ComponentInfo
Nothing ->
                     Conflict -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a b. a -> Either a b
Left (Conflict -> Either Conflict (Map QPN ComponentDependencyReasons))
-> Conflict -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a b. (a -> b) -> a -> b
$ QPN
-> ExposedComponent
-> DependencyReason QPN
-> (QPN -> ExposedComponent -> FailReason)
-> Conflict
mkConflict QPN
qpn ExposedComponent
comp DependencyReason QPN
dr QPN -> ExposedComponent -> FailReason
PackageRequiresMissingComponent
                 Just ComponentInfo
compInfo
                   | ComponentInfo -> IsVisible
compIsVisible ComponentInfo
compInfo IsVisible -> IsVisible -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsVisible
IsVisible Bool
False
                   , QPN
eqpn QPN -> QPN -> Bool
forall a. Eq a => a -> a -> Bool
/= QPN
qpn -- package components can depend on other components
                   ->
                     Conflict -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a b. a -> Either a b
Left (Conflict -> Either Conflict (Map QPN ComponentDependencyReasons))
-> Conflict -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a b. (a -> b) -> a -> b
$ QPN
-> ExposedComponent
-> DependencyReason QPN
-> (QPN -> ExposedComponent -> FailReason)
-> Conflict
mkConflict QPN
qpn ExposedComponent
comp DependencyReason QPN
dr QPN -> ExposedComponent -> FailReason
PackageRequiresPrivateComponent
                   | ComponentInfo -> IsBuildable
compIsBuildable ComponentInfo
compInfo IsBuildable -> IsBuildable -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsBuildable
IsBuildable Bool
False ->
                     Conflict -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a b. a -> Either a b
Left (Conflict -> Either Conflict (Map QPN ComponentDependencyReasons))
-> Conflict -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a b. (a -> b) -> a -> b
$ QPN
-> ExposedComponent
-> DependencyReason QPN
-> (QPN -> ExposedComponent -> FailReason)
-> Conflict
mkConflict QPN
qpn ExposedComponent
comp DependencyReason QPN
dr QPN -> ExposedComponent -> FailReason
PackageRequiresUnbuildableComponent
                   | Bool
otherwise -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a. Either a (Map QPN ComponentDependencyReasons)
success
           Maybe (Map ExposedComponent ComponentInfo)
Nothing    -> Either Conflict (Map QPN ComponentDependencyReasons)
forall a. Either a (Map QPN ComponentDependencyReasons)
success
    extendSingle Map QPN ComponentDependencyReasons
required LDep QPN
_                                         = Map QPN ComponentDependencyReasons
-> Either Conflict (Map QPN ComponentDependencyReasons)
forall a b. b -> Either a b
Right Map QPN ComponentDependencyReasons
required

    mkConflict :: QPN
               -> ExposedComponent
               -> DependencyReason QPN
               -> (QPN -> ExposedComponent -> FailReason)
               -> Conflict
    mkConflict :: QPN
-> ExposedComponent
-> DependencyReason QPN
-> (QPN -> ExposedComponent -> FailReason)
-> Conflict
mkConflict QPN
qpn ExposedComponent
comp DependencyReason QPN
dr QPN -> ExposedComponent -> FailReason
mkFailure =
      (Var QPN -> ConflictSet -> ConflictSet
CS.insert (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn) (DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet DependencyReason QPN
dr), QPN -> ExposedComponent -> FailReason
mkFailure QPN
qpn ExposedComponent
comp)


-- | Interface.
validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c
validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c
validateTree CompilerInfo
cinfo Index
idx PkgConfigDb
pkgConfigDb Tree d c
t = Validate (Tree d c) -> ValidateState -> Tree d c
forall a. Validate a -> ValidateState -> a
runValidate (Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
validate Tree d c
t) VS :: (Extension -> Bool)
-> (Language -> Bool)
-> (PkgconfigName -> PkgconfigVersionRange -> Bool)
-> Index
-> Map QPN (FlaggedDeps QPN)
-> PreAssignment
-> Map QPN (Map ExposedComponent ComponentInfo)
-> Map QPN ComponentDependencyReasons
-> QualifyOptions
-> ValidateState
VS {
    supportedExt :: Extension -> Bool
supportedExt        = (Extension -> Bool)
-> ([Extension] -> Extension -> Bool)
-> Maybe [Extension]
-> Extension
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Extension -> Bool
forall a b. a -> b -> a
const Bool
True) -- if compiler has no list of extensions, we assume everything is supported
                                (\ [Extension]
es -> let s :: Set Extension
s = [Extension] -> Set Extension
forall a. Ord a => [a] -> Set a
S.fromList [Extension]
es in \ Extension
x -> Extension -> Set Extension -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Extension
x Set Extension
s)
                                (CompilerInfo -> Maybe [Extension]
compilerInfoExtensions CompilerInfo
cinfo)
  , supportedLang :: Language -> Bool
supportedLang       = (Language -> Bool)
-> ([Language] -> Language -> Bool)
-> Maybe [Language]
-> Language
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Language -> Bool
forall a b. a -> b -> a
const Bool
True)
                                ((Language -> [Language] -> Bool) -> [Language] -> Language -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Language -> [Language] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
L.elem) -- use list lookup because language list is small and no Ord instance
                                (CompilerInfo -> Maybe [Language]
compilerInfoLanguages  CompilerInfo
cinfo)
  , presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool
presentPkgs         = PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool
pkgConfigPkgIsPresent PkgConfigDb
pkgConfigDb
  , index :: Index
index               = Index
idx
  , saved :: Map QPN (FlaggedDeps QPN)
saved               = Map QPN (FlaggedDeps QPN)
forall k a. Map k a
M.empty
  , pa :: PreAssignment
pa                  = PPreAssignment -> FAssignment -> SAssignment -> PreAssignment
PA PPreAssignment
forall k a. Map k a
M.empty FAssignment
forall k a. Map k a
M.empty SAssignment
forall k a. Map k a
M.empty
  , availableComponents :: Map QPN (Map ExposedComponent ComponentInfo)
availableComponents = Map QPN (Map ExposedComponent ComponentInfo)
forall k a. Map k a
M.empty
  , requiredComponents :: Map QPN ComponentDependencyReasons
requiredComponents  = Map QPN ComponentDependencyReasons
forall k a. Map k a
M.empty
  , qualifyOptions :: QualifyOptions
qualifyOptions      = Index -> QualifyOptions
defaultQualifyOptions Index
idx
  }