{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- TODO: remove this
{-# OPTIONS -fno-warn-incomplete-uni-patterns #-}
module Distribution.Solver.Modular.Linking (
    validateLinking
  ) where

import Prelude ()
import Distribution.Solver.Compat.Prelude hiding (get,put)

import Control.Exception (assert)
import Control.Monad.Reader
import Control.Monad.State
import Data.Map ((!))
import qualified Data.Map         as M
import qualified Data.Set         as S
import qualified Data.Traversable as T

import Distribution.Client.Utils.Assertion
import Distribution.Solver.Modular.Assignment
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 qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W

import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import Distribution.Types.Flag (unFlagName)

{-------------------------------------------------------------------------------
  Validation

  Validation of links is a separate pass that's performed after normal
  validation. Validation of links checks that if the tree indicates that a
  package is linked, then everything underneath that choice really matches the
  package we have linked to.

  This is interesting because it isn't unidirectional. Consider that we've
  chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.
  Now foo depends on bar. Because a.foo and b.foo are linked, it's required that
  a.bar and b.bar are also linked. However, it's not required that we actually
  choose a.bar before b.bar. Goal choice order is relatively free. It's possible
  that we choose a.bar first, but also possible that we choose b.bar first. In
  both cases, we have to recognize that we have freedom of choice for the first
  of the two, but no freedom of choice for the second.

  This is what LinkGroups are all about. Using LinkGroup, we can record (in the
  situation above) that a.bar and b.bar need to be linked even if we haven't
  chosen either of them yet.
-------------------------------------------------------------------------------}

data ValidateState = VS {
      ValidateState -> Index
vsIndex    :: Index
    , ValidateState -> Map QPN LinkGroup
vsLinks    :: Map QPN LinkGroup
    , ValidateState -> FAssignment
vsFlags    :: FAssignment
    , ValidateState -> SAssignment
vsStanzas  :: SAssignment
    , ValidateState -> QualifyOptions
vsQualifyOptions :: QualifyOptions

    -- Saved qualified dependencies. Every time 'validateLinking' 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)
vsSaved    :: Map QPN (FlaggedDeps QPN)
    }

type Validate = Reader ValidateState

-- | Validate linked packages
--
-- Verify that linked packages have
--
-- * Linked dependencies,
-- * Equal flag assignments
-- * Equal stanza assignments
validateLinking :: Index -> Tree d c -> Tree d c
validateLinking :: Index -> Tree d c -> Tree d c
validateLinking Index
index = (Reader ValidateState (Tree d c) -> ValidateState -> Tree d c
forall r a. Reader r a -> r -> a
`runReader` ValidateState
initVS) (Reader ValidateState (Tree d c) -> Tree d c)
-> (Tree d c -> Reader ValidateState (Tree d c))
-> Tree d c
-> Tree d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d c -> Reader ValidateState (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)
cs) =
      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)
-> ReaderT
     ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((POption -> Validate (Tree d c) -> Validate (Tree d c))
-> WeightedPSQ [Weight] POption (Validate (Tree d c))
-> ReaderT
     ValidateState Identity (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 (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) (WeightedPSQ [Weight] POption (Validate (Tree d c))
 -> ReaderT
      ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c)))
-> WeightedPSQ [Weight] POption (Validate (Tree d c))
-> ReaderT
     ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Validate (Tree d c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] POption (Tree d c)
cs)
    go (FChoice QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
t FlagType
m Bool
d WeightedPSQ [Weight] Bool (Tree d c)
cs) =
      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
t FlagType
m Bool
d (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
     ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool -> Validate (Tree d c) -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
     ValidateState Identity (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 (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) (WeightedPSQ [Weight] Bool (Validate (Tree d c))
 -> ReaderT
      ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c)))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
     ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
cs)
    go (SChoice QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
t     WeightedPSQ [Weight] Bool (Tree d c)
cs) =
      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
t     (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
     ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool -> Validate (Tree d c) -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
     ValidateState Identity (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 (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) (WeightedPSQ [Weight] Bool (Validate (Tree d c))
 -> ReaderT
      ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c)))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
     ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
cs)

    -- For the other nodes we just recurse
    go (GoalChoice RevDepMap
rdm           PSQ (Goal QPN) (Tree d c)
cs) = 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)
-> ReaderT ValidateState Identity (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)
-> ReaderT ValidateState Identity (PSQ (Goal QPN) (Tree d c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.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)
cs
    go (Done RevDepMap
revDepMap d
s)            = 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
$ RevDepMap -> d -> Tree d c
forall d c. RevDepMap -> d -> Tree d c
Done RevDepMap
revDepMap d
s
    go (Fail ConflictSet
conflictSet FailReason
failReason) = 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 ConflictSet
conflictSet FailReason
failReason

    -- Package choices
    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) opt :: POption
opt@(POption I
i Maybe PackagePath
_) Validate (Tree d c)
r = do
      ValidateState
vs <- ReaderT ValidateState Identity ValidateState
forall r (m :: * -> *). MonadReader r m => m r
ask
      let PInfo FlaggedDeps PackageName
deps Map ExposedComponent ComponentInfo
_ FlagInfo
_ Maybe FailReason
_ = ValidateState -> Index
vsIndex ValidateState
vs 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
          qdeps :: FlaggedDeps QPN
qdeps            = QualifyOptions -> QPN -> FlaggedDeps PackageName -> FlaggedDeps QPN
qualifyDeps (ValidateState -> QualifyOptions
vsQualifyOptions ValidateState
vs) QPN
qpn FlaggedDeps PackageName
deps
          newSaved :: Map QPN (FlaggedDeps QPN)
newSaved         = 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 (ValidateState -> Map QPN (FlaggedDeps QPN)
vsSaved ValidateState
vs)
      case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption QPN
qpn POption
opt FlaggedDeps QPN
qdeps) ValidateState
vs of
        Left  (ConflictSet
cs, String
err) -> 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 ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
        Right ValidateState
vs'       -> (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 -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs' { vsSaved :: Map QPN (FlaggedDeps QPN)
vsSaved = Map QPN (FlaggedDeps QPN)
newSaved }) Validate (Tree d c)
r

    -- Flag choices
    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 Bool
b Validate (Tree d c)
r = do
      ValidateState
vs <- ReaderT ValidateState Identity ValidateState
forall r (m :: * -> *). MonadReader r m => m r
ask
      case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (QFN -> Bool -> UpdateState ()
pickFlag QFN
qfn Bool
b) ValidateState
vs of
        Left  (ConflictSet
cs, String
err) -> 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 ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
        Right ValidateState
vs'       -> (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 -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs') Validate (Tree d c)
r

    -- Stanza choices (much the same as flag choices)
    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 Bool
b Validate (Tree d c)
r = do
      ValidateState
vs <- ReaderT ValidateState Identity ValidateState
forall r (m :: * -> *). MonadReader r m => m r
ask
      case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (QSN -> Bool -> UpdateState ()
pickStanza QSN
qsn Bool
b) ValidateState
vs of
        Left  (ConflictSet
cs, String
err) -> 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 ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
        Right ValidateState
vs'       -> (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 -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs') Validate (Tree d c)
r

    initVS :: ValidateState
    initVS :: ValidateState
initVS = VS :: Index
-> Map QPN LinkGroup
-> FAssignment
-> SAssignment
-> QualifyOptions
-> Map QPN (FlaggedDeps QPN)
-> ValidateState
VS {
        vsIndex :: Index
vsIndex   = Index
index
      , vsLinks :: Map QPN LinkGroup
vsLinks   = Map QPN LinkGroup
forall k a. Map k a
M.empty
      , vsFlags :: FAssignment
vsFlags   = FAssignment
forall k a. Map k a
M.empty
      , vsStanzas :: SAssignment
vsStanzas = SAssignment
forall k a. Map k a
M.empty
      , vsQualifyOptions :: QualifyOptions
vsQualifyOptions = Index -> QualifyOptions
defaultQualifyOptions Index
index
      , vsSaved :: Map QPN (FlaggedDeps QPN)
vsSaved   = Map QPN (FlaggedDeps QPN)
forall k a. Map k a
M.empty
      }

{-------------------------------------------------------------------------------
  Updating the validation state
-------------------------------------------------------------------------------}

type Conflict = (ConflictSet, String)

newtype UpdateState a = UpdateState {
    UpdateState a -> StateT ValidateState (Either Conflict) a
unUpdateState :: StateT ValidateState (Either Conflict) a
  }
  deriving (a -> UpdateState b -> UpdateState a
(a -> b) -> UpdateState a -> UpdateState b
(forall a b. (a -> b) -> UpdateState a -> UpdateState b)
-> (forall a b. a -> UpdateState b -> UpdateState a)
-> Functor UpdateState
forall a b. a -> UpdateState b -> UpdateState a
forall a b. (a -> b) -> UpdateState a -> UpdateState b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> UpdateState b -> UpdateState a
$c<$ :: forall a b. a -> UpdateState b -> UpdateState a
fmap :: (a -> b) -> UpdateState a -> UpdateState b
$cfmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
Functor, Functor UpdateState
a -> UpdateState a
Functor UpdateState
-> (forall a. a -> UpdateState a)
-> (forall a b.
    UpdateState (a -> b) -> UpdateState a -> UpdateState b)
-> (forall a b c.
    (a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState b)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState a)
-> Applicative UpdateState
UpdateState a -> UpdateState b -> UpdateState b
UpdateState a -> UpdateState b -> UpdateState a
UpdateState (a -> b) -> UpdateState a -> UpdateState b
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
forall a. a -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState b
forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState 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
<* :: UpdateState a -> UpdateState b -> UpdateState a
$c<* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
*> :: UpdateState a -> UpdateState b -> UpdateState b
$c*> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
liftA2 :: (a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
$cliftA2 :: forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
<*> :: UpdateState (a -> b) -> UpdateState a -> UpdateState b
$c<*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
pure :: a -> UpdateState a
$cpure :: forall a. a -> UpdateState a
$cp1Applicative :: Functor UpdateState
Applicative, Applicative UpdateState
a -> UpdateState a
Applicative UpdateState
-> (forall a b.
    UpdateState a -> (a -> UpdateState b) -> UpdateState b)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState b)
-> (forall a. a -> UpdateState a)
-> Monad UpdateState
UpdateState a -> (a -> UpdateState b) -> UpdateState b
UpdateState a -> UpdateState b -> UpdateState b
forall a. a -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState b
forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState 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 -> UpdateState a
$creturn :: forall a. a -> UpdateState a
>> :: UpdateState a -> UpdateState b -> UpdateState b
$c>> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
>>= :: UpdateState a -> (a -> UpdateState b) -> UpdateState b
$c>>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
$cp1Monad :: Applicative UpdateState
Monad)

instance MonadState ValidateState UpdateState where
  get :: UpdateState ValidateState
get    = StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) ValidateState
 -> UpdateState ValidateState)
-> StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState
forall a b. (a -> b) -> a -> b
$ StateT ValidateState (Either Conflict) ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
  put :: ValidateState -> UpdateState ()
put ValidateState
st = StateT ValidateState (Either Conflict) () -> UpdateState ()
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) () -> UpdateState ())
-> StateT ValidateState (Either Conflict) () -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ do
             Bool
-> StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ()
forall a. Bool -> a -> a
expensiveAssert (Map QPN LinkGroup -> Bool
lgInvariant (Map QPN LinkGroup -> Bool) -> Map QPN LinkGroup -> Bool
forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
st) (StateT ValidateState (Either Conflict) ()
 -> StateT ValidateState (Either Conflict) ())
-> StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ()
forall a b. (a -> b) -> a -> b
$ () -> StateT ValidateState (Either Conflict) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             ValidateState -> StateT ValidateState (Either Conflict) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ValidateState
st

lift' :: Either Conflict a -> UpdateState a
lift' :: Either Conflict a -> UpdateState a
lift' = StateT ValidateState (Either Conflict) a -> UpdateState a
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) a -> UpdateState a)
-> (Either Conflict a -> StateT ValidateState (Either Conflict) a)
-> Either Conflict a
-> UpdateState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Conflict a -> StateT ValidateState (Either Conflict) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

conflict :: Conflict -> UpdateState a
conflict :: Conflict -> UpdateState a
conflict = Either Conflict a -> UpdateState a
forall a. Either Conflict a -> UpdateState a
lift' (Either Conflict a -> UpdateState a)
-> (Conflict -> Either Conflict a) -> Conflict -> UpdateState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conflict -> Either Conflict a
forall a b. a -> Either a b
Left

execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState = StateT ValidateState (Either Conflict) ()
-> ValidateState -> Either Conflict ValidateState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT ValidateState (Either Conflict) ()
 -> ValidateState -> Either Conflict ValidateState)
-> (UpdateState () -> StateT ValidateState (Either Conflict) ())
-> UpdateState ()
-> ValidateState
-> Either Conflict ValidateState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateState () -> StateT ValidateState (Either Conflict) ()
forall a. UpdateState a -> StateT ValidateState (Either Conflict) a
unUpdateState

pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption QPN
qpn (POption I
i Maybe PackagePath
Nothing)    FlaggedDeps QPN
_deps = QPN -> I -> UpdateState ()
pickConcrete QPN
qpn I
i
pickPOption QPN
qpn (POption I
i (Just PackagePath
pp'))  FlaggedDeps QPN
deps = QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
pickLink     QPN
qpn I
i PackagePath
pp' FlaggedDeps QPN
deps

pickConcrete :: QPN -> I -> UpdateState ()
pickConcrete :: QPN -> I -> UpdateState ()
pickConcrete qpn :: QPN
qpn@(Q PackagePath
pp PackageName
_) I
i = do
    ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
    case QPN -> Map QPN LinkGroup -> Maybe LinkGroup
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QPN
qpn (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs) of
      -- Package is not yet in a LinkGroup. Create a new singleton link group.
      Maybe LinkGroup
Nothing -> do
        let lg :: LinkGroup
lg = QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn (PI PackagePath -> Maybe (PI PackagePath)
forall a. a -> Maybe a
Just (PI PackagePath -> Maybe (PI PackagePath))
-> PI PackagePath -> Maybe (PI PackagePath)
forall a b. (a -> b) -> a -> b
$ PackagePath -> I -> PI PackagePath
forall qpn. qpn -> I -> PI qpn
PI PackagePath
pp I
i)
        LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg

      -- Package is already in a link group. Since we are picking a concrete
      -- instance here, it must by definition be the canonical package.
      Just LinkGroup
lg ->
        LinkGroup -> QPN -> I -> UpdateState ()
makeCanonical LinkGroup
lg QPN
qpn I
i

pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
pickLink qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) I
i PackagePath
pp' FlaggedDeps QPN
deps = do
    ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get

    -- The package might already be in a link group
    -- (because one of its reverse dependencies is)
    let lgSource :: LinkGroup
lgSource = case QPN -> Map QPN LinkGroup -> Maybe LinkGroup
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QPN
qpn (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs) of
                     Maybe LinkGroup
Nothing -> QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn Maybe (PI PackagePath)
forall a. Maybe a
Nothing
                     Just LinkGroup
lg -> LinkGroup
lg

    -- Find the link group for the package we are linking to
    --
    -- Since the builder never links to a package without having first picked a
    -- concrete instance for that package, and since we create singleton link
    -- groups for concrete instances, this link group must exist (and must
    -- in fact already have a canonical member).
    let target :: QPN
target   = PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn
        lgTarget :: LinkGroup
lgTarget = ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
target

    -- Verify here that the member we add is in fact for the same package and
    -- matches the version of the canonical instance. However, violations of
    -- these checks would indicate a bug in the linker, not a true conflict.
    let sanityCheck :: Maybe (PI PackagePath) -> Bool
        sanityCheck :: Maybe (PI PackagePath) -> Bool
sanityCheck Maybe (PI PackagePath)
Nothing              = Bool
False
        sanityCheck (Just (PI PackagePath
_ I
canonI)) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== LinkGroup -> PackageName
lgPackage LinkGroup
lgTarget Bool -> Bool -> Bool
&& I
i I -> I -> Bool
forall a. Eq a => a -> a -> Bool
== I
canonI
    Bool -> UpdateState () -> UpdateState ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe (PI PackagePath) -> Bool
sanityCheck (LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lgTarget)) (UpdateState () -> UpdateState ())
-> UpdateState () -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Merge the two link groups (updateLinkGroup will propagate the change)
    LinkGroup
lgTarget' <- Either Conflict LinkGroup -> UpdateState LinkGroup
forall a. Either Conflict a -> UpdateState a
lift' (Either Conflict LinkGroup -> UpdateState LinkGroup)
-> Either Conflict LinkGroup -> UpdateState LinkGroup
forall a b. (a -> b) -> a -> b
$ ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ConflictSet
CS.empty LinkGroup
lgSource LinkGroup
lgTarget
    LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lgTarget'

    -- Make sure all dependencies are linked as well
    QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps QPN
target FlaggedDeps QPN
deps

makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()
makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()
makeCanonical LinkGroup
lg qpn :: QPN
qpn@(Q PackagePath
pp PackageName
_) I
i =
    case LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg of
      -- There is already a canonical member. Fail.
      Just PI PackagePath
_ ->
        Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( Var QPN -> ConflictSet -> ConflictSet
CS.insert (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn) (LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg)
                 ,    String
"cannot make " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" canonical member of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg
                 )
      Maybe (PI PackagePath)
Nothing -> do
        let lg' :: LinkGroup
lg' = LinkGroup
lg { lgCanon :: Maybe (PI PackagePath)
lgCanon = PI PackagePath -> Maybe (PI PackagePath)
forall a. a -> Maybe a
Just (PackagePath -> I -> PI PackagePath
forall qpn. qpn -> I -> PI qpn
PI PackagePath
pp I
i) }
        LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg'

-- | Link the dependencies of linked parents.
--
-- When we decide to link one package against another we walk through the
-- package's direct dependencies and make sure that they're all linked to each
-- other by merging their link groups (or creating new singleton link groups if
-- they don't have link groups yet). We do not need to do this recursively,
-- because having the direct dependencies in a link group means that we must
-- have already made or will make sooner or later a link choice for one of these
-- as well, and cover their dependencies at that point.
linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps QPN
target = \FlaggedDeps QPN
deps -> do
    -- linkDeps is called in two places: when we first link one package to
    -- another, and when we discover more dependencies of an already linked
    -- package after doing some flag assignment. It is therefore important that
    -- flag assignments cannot influence _how_ dependencies are qualified;
    -- fortunately this is a documented property of 'qualifyDeps'.
    FlaggedDeps QPN
rdeps <- FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify FlaggedDeps QPN
deps
    FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
deps FlaggedDeps QPN
rdeps
  where
    go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
    go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go = (FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ())
-> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
go1

    go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
    go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
go1 FlaggedDep QPN
dep FlaggedDep QPN
rdep = case (FlaggedDep QPN
dep, FlaggedDep QPN
rdep) of
      (Simple (LDep DependencyReason QPN
dr1 (Dep (PkgComponent QPN
qpn ExposedComponent
_) CI
_)) Component
_, ~(Simple (LDep DependencyReason QPN
dr2 (Dep (PkgComponent QPN
qpn' ExposedComponent
_) CI
_)) Component
_)) -> do
        ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
        let lg :: LinkGroup
lg   = LinkGroup -> QPN -> Map QPN LinkGroup -> LinkGroup
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn  Maybe (PI PackagePath)
forall a. Maybe a
Nothing) QPN
qpn  (Map QPN LinkGroup -> LinkGroup) -> Map QPN LinkGroup -> LinkGroup
forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
            lg' :: LinkGroup
lg'  = LinkGroup -> QPN -> Map QPN LinkGroup -> LinkGroup
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn' Maybe (PI PackagePath)
forall a. Maybe a
Nothing) QPN
qpn' (Map QPN LinkGroup -> LinkGroup) -> Map QPN LinkGroup -> LinkGroup
forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
        LinkGroup
lg'' <- Either Conflict LinkGroup -> UpdateState LinkGroup
forall a. Either Conflict a -> UpdateState a
lift' (Either Conflict LinkGroup -> UpdateState LinkGroup)
-> Either Conflict LinkGroup -> UpdateState LinkGroup
forall a b. (a -> b) -> a -> b
$ ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ((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
dr1 DependencyReason QPN
dr2) LinkGroup
lg LinkGroup
lg'
        LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg''
      (Flagged QFN
fn FInfo
_ FlaggedDeps QPN
t FlaggedDeps QPN
f, ~(Flagged QFN
_ FInfo
_ FlaggedDeps QPN
t' FlaggedDeps QPN
f')) -> do
        ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
        case QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QFN
fn (ValidateState -> FAssignment
vsFlags ValidateState
vs) of
          Maybe Bool
Nothing    -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- flag assignment not yet known
          Just Bool
True  -> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
t FlaggedDeps QPN
t'
          Just Bool
False -> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
f FlaggedDeps QPN
f'
      (Stanza QSN
sn FlaggedDeps QPN
t, ~(Stanza QSN
_ FlaggedDeps QPN
t')) -> do
        ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
        case QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QSN
sn (ValidateState -> SAssignment
vsStanzas ValidateState
vs) of
          Maybe Bool
Nothing    -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- stanza assignment not yet known
          Just Bool
True  -> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
t FlaggedDeps QPN
t'
          Just Bool
False -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- stanza not enabled; no new deps
    -- For extensions and language dependencies, there is nothing to do.
    -- No choice is involved, just checking, so there is nothing to link.
    -- The same goes for pkg-config constraints.
      (Simple (LDep DependencyReason QPN
_ (Ext  Extension
_))   Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (Simple (LDep DependencyReason QPN
_ (Lang Language
_))   Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (Simple (LDep DependencyReason QPN
_ (Pkg  PkgconfigName
_ PkgconfigVersionRange
_)) Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
    requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify FlaggedDeps QPN
deps = do
      ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
      FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
forall (m :: * -> *) a. Monad m => a -> m a
return (FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN))
-> FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
forall a b. (a -> b) -> a -> b
$ QualifyOptions -> QPN -> FlaggedDeps PackageName -> FlaggedDeps QPN
qualifyDeps (ValidateState -> QualifyOptions
vsQualifyOptions ValidateState
vs) QPN
target (FlaggedDeps QPN -> FlaggedDeps PackageName
unqualifyDeps FlaggedDeps QPN
deps)

pickFlag :: QFN -> Bool -> UpdateState ()
pickFlag :: QFN -> Bool -> UpdateState ()
pickFlag QFN
qfn Bool
b = do
    (ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsFlags :: FAssignment
vsFlags = QFN -> Bool -> FAssignment -> FAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QFN
qfn Bool
b (ValidateState -> FAssignment
vsFlags ValidateState
vs) }
    QFN -> UpdateState ()
verifyFlag QFN
qfn
    Var QPN -> Bool -> UpdateState ()
linkNewDeps (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn) Bool
b

pickStanza :: QSN -> Bool -> UpdateState ()
pickStanza :: QSN -> Bool -> UpdateState ()
pickStanza QSN
qsn Bool
b = do
    (ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsStanzas :: SAssignment
vsStanzas = QSN -> Bool -> SAssignment -> SAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QSN
qsn Bool
b (ValidateState -> SAssignment
vsStanzas ValidateState
vs) }
    QSN -> UpdateState ()
verifyStanza QSN
qsn
    Var QPN -> Bool -> UpdateState ()
linkNewDeps (QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn) Bool
b

-- | Link dependencies that we discover after making a flag or stanza choice.
--
-- When we make a flag choice for a package, then new dependencies for that
-- package might become available. If the package under consideration is in a
-- non-trivial link group, then these new dependencies have to be linked as
-- well. In linkNewDeps, we compute such new dependencies and make sure they are
-- linked.
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps Var QPN
var Bool
b = do
    ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
    let qpn :: QPN
qpn@(Q PackagePath
pp PackageName
pn)           = Var QPN -> QPN
forall qpn. Var qpn -> qpn
varPN Var QPN
var
        qdeps :: FlaggedDeps QPN
qdeps                   = ValidateState -> Map QPN (FlaggedDeps QPN)
vsSaved ValidateState
vs Map QPN (FlaggedDeps QPN) -> QPN -> FlaggedDeps QPN
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn
        lg :: LinkGroup
lg                      = ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn
        newDeps :: FlaggedDeps QPN
newDeps                 = ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs FlaggedDeps QPN
qdeps
        linkedTo :: Set PackagePath
linkedTo                = PackagePath -> Set PackagePath -> Set PackagePath
forall a. Ord a => a -> Set a -> Set a
S.delete PackagePath
pp (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)
    [PackagePath] -> (PackagePath -> UpdateState ()) -> UpdateState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList Set PackagePath
linkedTo) ((PackagePath -> UpdateState ()) -> UpdateState ())
-> (PackagePath -> UpdateState ()) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \PackagePath
pp' -> QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) FlaggedDeps QPN
newDeps
  where
    findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
    findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs = (FlaggedDep QPN -> FlaggedDeps QPN)
-> FlaggedDeps QPN -> FlaggedDeps QPN
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
findNewDeps' ValidateState
vs)

    findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
    findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
findNewDeps' ValidateState
_  (Simple LDep QPN
_ Component
_)        = []
    findNewDeps' ValidateState
vs (Flagged QFN
qfn FInfo
_ FlaggedDeps QPN
t FlaggedDeps QPN
f) =
      case (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== Var QPN
var, QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QFN
qfn (ValidateState -> FAssignment
vsFlags ValidateState
vs)) of
        (Bool
True, Maybe Bool
_)    -> if Bool
b then FlaggedDeps QPN
t else FlaggedDeps QPN
f
        (Bool
_, Maybe Bool
Nothing) -> [] -- not yet known
        (Bool
_, Just Bool
b') -> ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs (if Bool
b' then FlaggedDeps QPN
t else FlaggedDeps QPN
f)
    findNewDeps' ValidateState
vs (Stanza QSN
qsn FlaggedDeps QPN
t) =
      case (QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== Var QPN
var, QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QSN
qsn (ValidateState -> SAssignment
vsStanzas ValidateState
vs)) of
        (Bool
True, Maybe Bool
_)    -> if Bool
b then FlaggedDeps QPN
t else []
        (Bool
_, Maybe Bool
Nothing) -> [] -- not yet known
        (Bool
_, Just Bool
b') -> ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs (if Bool
b' then FlaggedDeps QPN
t else [])

updateLinkGroup :: LinkGroup -> UpdateState ()
updateLinkGroup :: LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg = do
    LinkGroup -> UpdateState ()
verifyLinkGroup LinkGroup
lg
    (ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs {
        vsLinks :: Map QPN LinkGroup
vsLinks =           [(QPN, LinkGroup)] -> Map QPN LinkGroup
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((PackagePath -> (QPN, LinkGroup))
-> [PackagePath] -> [(QPN, LinkGroup)]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> (QPN, LinkGroup)
aux (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)))
                  Map QPN LinkGroup -> Map QPN LinkGroup -> Map QPN LinkGroup
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
      }
  where
    aux :: PackagePath -> (QPN, LinkGroup)
aux PackagePath
pp = (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg), LinkGroup
lg)

{-------------------------------------------------------------------------------
  Verification
-------------------------------------------------------------------------------}

verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup LinkGroup
lg =
    case LinkGroup -> Maybe I
lgInstance LinkGroup
lg of
      -- No instance picked yet. Nothing to verify
      Maybe I
Nothing ->
        () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- We picked an instance. Verify flags and stanzas
      -- TODO: The enumeration of OptionalStanza names is very brittle;
      -- if a constructor is added to the datatype we won't notice it here
      Just I
i -> do
        ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
        let PInfo FlaggedDeps PackageName
_deps Map ExposedComponent ComponentInfo
_exes FlagInfo
finfo Maybe FailReason
_ = ValidateState -> Index
vsIndex ValidateState
vs Index -> PackageName -> Map I PInfo
forall k a. Ord k => Map k a -> k -> a
! LinkGroup -> PackageName
lgPackage LinkGroup
lg Map I PInfo -> I -> PInfo
forall k a. Ord k => Map k a -> k -> a
! I
i
            flags :: [Flag]
flags   = FlagInfo -> [Flag]
forall k a. Map k a -> [k]
M.keys FlagInfo
finfo
            stanzas :: [OptionalStanza]
stanzas = [OptionalStanza
TestStanzas, OptionalStanza
BenchStanzas]
        [Flag] -> (Flag -> UpdateState ()) -> UpdateState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Flag]
flags ((Flag -> UpdateState ()) -> UpdateState ())
-> (Flag -> UpdateState ()) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \Flag
fn -> do
          let flag :: FN PackageName
flag = PackageName -> Flag -> FN PackageName
forall qpn. qpn -> Flag -> FN qpn
FN (LinkGroup -> PackageName
lgPackage LinkGroup
lg) Flag
fn
          FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' FN PackageName
flag LinkGroup
lg
        [OptionalStanza]
-> (OptionalStanza -> UpdateState ()) -> UpdateState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [OptionalStanza]
stanzas ((OptionalStanza -> UpdateState ()) -> UpdateState ())
-> (OptionalStanza -> UpdateState ()) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \OptionalStanza
sn -> do
          let stanza :: SN PackageName
stanza = PackageName -> OptionalStanza -> SN PackageName
forall qpn. qpn -> OptionalStanza -> SN qpn
SN (LinkGroup -> PackageName
lgPackage LinkGroup
lg) OptionalStanza
sn
          SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' SN PackageName
stanza LinkGroup
lg

verifyFlag :: QFN -> UpdateState ()
verifyFlag :: QFN -> UpdateState ()
verifyFlag (FN qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) Flag
fn) = do
    ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
    -- We can only pick a flag after picking an instance; link group must exist
    FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' (PackageName -> Flag -> FN PackageName
forall qpn. qpn -> Flag -> FN qpn
FN PackageName
pn Flag
fn) (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn)

verifyStanza :: QSN -> UpdateState ()
verifyStanza :: QSN -> UpdateState ()
verifyStanza (SN qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) OptionalStanza
sn) = do
    ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
    -- We can only pick a stanza after picking an instance; link group must exist
    SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' (PackageName -> OptionalStanza -> SN PackageName
forall qpn. qpn -> OptionalStanza -> SN qpn
SN PackageName
pn OptionalStanza
sn) (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn)

-- | Verify that all packages in the link group agree on flag assignments
--
-- For the given flag and the link group, obtain all assignments for the flag
-- that have already been made for link group members, and check that they are
-- equal.
verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
verifyFlag' :: FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' (FN PackageName
pn Flag
fn) LinkGroup
lg = do
    ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
    let flags :: [QFN]
flags = (PackagePath -> QFN) -> [PackagePath] -> [QFN]
forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> QPN -> Flag -> QFN
forall qpn. qpn -> Flag -> FN qpn
FN (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) Flag
fn) (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
        vals :: [Maybe Bool]
vals  = (QFN -> Maybe Bool) -> [QFN] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> FAssignment
vsFlags ValidateState
vs) [QFN]
flags
    if [Bool] -> Bool
forall a. Eq a => [a] -> Bool
allEqual ([Maybe Bool] -> [Bool]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals) -- We ignore not-yet assigned flags
      then () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList ((QFN -> Var QPN) -> [QFN] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F [QFN]
flags) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
                    , String
"flag \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Flag -> String
unFlagName Flag
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" incompatible"
                    )

-- | Verify that all packages in the link group agree on stanza assignments
--
-- For the given stanza and the link group, obtain all assignments for the
-- stanza that have already been made for link group members, and check that
-- they are equal.
--
-- This function closely mirrors 'verifyFlag''.
verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
verifyStanza' :: SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' (SN PackageName
pn OptionalStanza
sn) LinkGroup
lg = do
    ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
    let stanzas :: [QSN]
stanzas = (PackagePath -> QSN) -> [PackagePath] -> [QSN]
forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> QPN -> OptionalStanza -> QSN
forall qpn. qpn -> OptionalStanza -> SN qpn
SN (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) OptionalStanza
sn) (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
        vals :: [Maybe Bool]
vals    = (QSN -> Maybe Bool) -> [QSN] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> SAssignment
vsStanzas ValidateState
vs) [QSN]
stanzas
    if [Bool] -> Bool
forall a. Eq a => [a] -> Bool
allEqual ([Maybe Bool] -> [Bool]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals) -- We ignore not-yet assigned stanzas
      then () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList ((QSN -> Var QPN) -> [QSN] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S [QSN]
stanzas) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
                    , String
"stanza \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionalStanza -> String
showStanza OptionalStanza
sn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" incompatible"
                    )

{-------------------------------------------------------------------------------
  Link groups
-------------------------------------------------------------------------------}

-- | Set of packages that must be linked together
--
-- A LinkGroup is between several qualified package names. In the validation
-- state, we maintain a map vsLinks from qualified package names to link groups.
-- There is an invariant that for all members of a link group, vsLinks must map
-- to the same link group. The function updateLinkGroup can be used to
-- re-establish this invariant after creating or expanding a LinkGroup.
data LinkGroup = LinkGroup {
      -- | The name of the package of this link group
      LinkGroup -> PackageName
lgPackage :: PN

      -- | The canonical member of this link group (the one where we picked
      -- a concrete instance). Once we have picked a canonical member, all
      -- other packages must link to this one.
      --
      -- We may not know this yet (if we are constructing link groups
      -- for dependencies)
    , LinkGroup -> Maybe (PI PackagePath)
lgCanon :: Maybe (PI PackagePath)

      -- | The members of the link group
    , LinkGroup -> Set PackagePath
lgMembers :: Set PackagePath

      -- | The set of variables that should be added to the conflict set if
      -- something goes wrong with this link set (in addition to the members
      -- of the link group itself)
    , LinkGroup -> ConflictSet
lgBlame :: ConflictSet
    }
    deriving (Int -> LinkGroup -> String -> String
[LinkGroup] -> String -> String
LinkGroup -> String
(Int -> LinkGroup -> String -> String)
-> (LinkGroup -> String)
-> ([LinkGroup] -> String -> String)
-> Show LinkGroup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LinkGroup] -> String -> String
$cshowList :: [LinkGroup] -> String -> String
show :: LinkGroup -> String
$cshow :: LinkGroup -> String
showsPrec :: Int -> LinkGroup -> String -> String
$cshowsPrec :: Int -> LinkGroup -> String -> String
Show, LinkGroup -> LinkGroup -> Bool
(LinkGroup -> LinkGroup -> Bool)
-> (LinkGroup -> LinkGroup -> Bool) -> Eq LinkGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinkGroup -> LinkGroup -> Bool
$c/= :: LinkGroup -> LinkGroup -> Bool
== :: LinkGroup -> LinkGroup -> Bool
$c== :: LinkGroup -> LinkGroup -> Bool
Eq)

-- | Invariant for the set of link groups: every element in the link group
-- must be pointing to the /same/ link group
lgInvariant :: Map QPN LinkGroup -> Bool
lgInvariant :: Map QPN LinkGroup -> Bool
lgInvariant Map QPN LinkGroup
links = (LinkGroup -> Bool) -> [LinkGroup] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LinkGroup -> Bool
invGroup (Map QPN LinkGroup -> [LinkGroup]
forall k a. Map k a -> [a]
M.elems Map QPN LinkGroup
links)
  where
    invGroup :: LinkGroup -> Bool
    invGroup :: LinkGroup -> Bool
invGroup LinkGroup
lg = [Maybe LinkGroup] -> Bool
forall a. Eq a => [a] -> Bool
allEqual ([Maybe LinkGroup] -> Bool) -> [Maybe LinkGroup] -> Bool
forall a b. (a -> b) -> a -> b
$ (QPN -> Maybe LinkGroup) -> [QPN] -> [Maybe LinkGroup]
forall a b. (a -> b) -> [a] -> [b]
map (QPN -> Map QPN LinkGroup -> Maybe LinkGroup
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map QPN LinkGroup
links) [QPN]
members
      where
        members :: [QPN]
        members :: [QPN]
members = (PackagePath -> QPN) -> [PackagePath] -> [QPN]
forall a b. (a -> b) -> [a] -> [b]
map (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
`Q` LinkGroup -> PackageName
lgPackage LinkGroup
lg) ([PackagePath] -> [QPN]) -> [PackagePath] -> [QPN]
forall a b. (a -> b) -> a -> b
$ Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)

-- | Package version of this group
--
-- This is only known once we have picked a canonical element.
lgInstance :: LinkGroup -> Maybe I
lgInstance :: LinkGroup -> Maybe I
lgInstance = (PI PackagePath -> I) -> Maybe (PI PackagePath) -> Maybe I
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PI PackagePath
_ I
i) -> I
i) (Maybe (PI PackagePath) -> Maybe I)
-> (LinkGroup -> Maybe (PI PackagePath)) -> LinkGroup -> Maybe I
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkGroup -> Maybe (PI PackagePath)
lgCanon

showLinkGroup :: LinkGroup -> String
showLinkGroup :: LinkGroup -> String
showLinkGroup LinkGroup
lg =
    String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((PackagePath -> String) -> [PackagePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> String
showMember (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
  where
    showMember :: PackagePath -> String
    showMember :: PackagePath -> String
showMember PackagePath
pp = case LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg of
                      Just (PI PackagePath
pp' I
_i) | PackagePath
pp PackagePath -> PackagePath -> Bool
forall a. Eq a => a -> a -> Bool
== PackagePath
pp' -> String
"*"
                      Maybe (PI PackagePath)
_otherwise                   -> String
""
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ case LinkGroup -> Maybe I
lgInstance LinkGroup
lg of
                      Maybe I
Nothing -> QPN -> String
showQPN (PackagePath -> QPN
qpn PackagePath
pp)
                      Just I
i  -> PI QPN -> String
showPI (QPN -> I -> PI QPN
forall qpn. qpn -> I -> PI qpn
PI (PackagePath -> QPN
qpn PackagePath
pp) I
i)

    qpn :: PackagePath -> QPN
    qpn :: PackagePath -> QPN
qpn PackagePath
pp = PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg)

-- | Creates a link group that contains a single member.
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton (Q PackagePath
pp PackageName
pn) Maybe (PI PackagePath)
canon = LinkGroup :: PackageName
-> Maybe (PI PackagePath)
-> Set PackagePath
-> ConflictSet
-> LinkGroup
LinkGroup {
      lgPackage :: PackageName
lgPackage = PackageName
pn
    , lgCanon :: Maybe (PI PackagePath)
lgCanon   = Maybe (PI PackagePath)
canon
    , lgMembers :: Set PackagePath
lgMembers = PackagePath -> Set PackagePath
forall a. a -> Set a
S.singleton PackagePath
pp
    , lgBlame :: ConflictSet
lgBlame   = ConflictSet
CS.empty
    }

lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ConflictSet
blame LinkGroup
lg LinkGroup
lg' = do
    Maybe (PI PackagePath)
canon <- Maybe (PI PackagePath)
-> Maybe (PI PackagePath)
-> Either Conflict (Maybe (PI PackagePath))
forall a. Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
pick (LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg) (LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg')
    LinkGroup -> Either Conflict LinkGroup
forall (m :: * -> *) a. Monad m => a -> m a
return LinkGroup :: PackageName
-> Maybe (PI PackagePath)
-> Set PackagePath
-> ConflictSet
-> LinkGroup
LinkGroup {
        lgPackage :: PackageName
lgPackage = LinkGroup -> PackageName
lgPackage LinkGroup
lg
      , lgCanon :: Maybe (PI PackagePath)
lgCanon   = Maybe (PI PackagePath)
canon
      , lgMembers :: Set PackagePath
lgMembers = LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg Set PackagePath -> Set PackagePath -> Set PackagePath
forall a. Ord a => Set a -> Set a -> Set a
`S.union` LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg'
      , lgBlame :: ConflictSet
lgBlame   = [ConflictSet] -> ConflictSet
CS.unions [ConflictSet
blame, LinkGroup -> ConflictSet
lgBlame LinkGroup
lg, LinkGroup -> ConflictSet
lgBlame LinkGroup
lg']
      }
  where
    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
    pick :: Maybe a -> Maybe a -> Either Conflict (Maybe a)
pick Maybe a
Nothing  Maybe a
Nothing  = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    pick (Just a
x) Maybe a
Nothing  = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
    pick Maybe a
Nothing  (Just a
y) = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
y
    pick (Just a
x) (Just a
y) =
      if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
                else Conflict -> Either Conflict (Maybe a)
forall a b. a -> Either a b
Left ( [ConflictSet] -> ConflictSet
CS.unions [
                               ConflictSet
blame
                             , LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
                             , LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg'
                             ]
                          ,    String
"cannot merge " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg'
                          )

lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg =
               [Var QPN] -> ConflictSet
CS.fromList ((PackagePath -> Var QPN) -> [PackagePath] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> Var QPN
aux (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)))
    ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgBlame LinkGroup
lg
  where
    aux :: PackagePath -> Var QPN
aux PackagePath
pp = QPN -> Var QPN
forall qpn. qpn -> Var qpn
P (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg))

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

allEqual :: Eq a => [a] -> Bool
allEqual :: [a] -> Bool
allEqual []       = Bool
True
allEqual [a
_]      = Bool
True
allEqual (a
x:a
y:[a]
ys) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Eq a => [a] -> Bool
allEqual (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)