    {-# 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 (forM_, zipWithM_)
    import Control.Monad.Reader (Reader, runReader, local, ask)
    import Control.Monad.State (MonadState, StateT, get, put, modify, execStateT)
    import Control.Monad.Trans (lift)
    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 :: forall d c. 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 :: forall d c. 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))
    -> ReaderT ValidateState Identity (Tree d c)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (POption
     -> ReaderT ValidateState Identity (Tree d c)
     -> ReaderT ValidateState Identity (Tree d c))
    -> WeightedPSQ
         [Weight] POption (ReaderT ValidateState Identity (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
    -> ReaderT ValidateState Identity (Tree d c)
    -> ReaderT ValidateState Identity (Tree d c)
    forall d c.
    QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
    goP QPN
    qpn) ((Tree d c -> ReaderT ValidateState Identity (Tree d c))
    -> WeightedPSQ [Weight] POption (Tree d c)
    -> WeightedPSQ
         [Weight] POption (ReaderT ValidateState Identity (Tree d c))
    forall a b.
    (a -> b)
    -> WeightedPSQ [Weight] POption a -> WeightedPSQ [Weight] POption b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Tree d c -> ReaderT ValidateState Identity (Tree d c)
    forall d c. Tree d c -> Validate (Tree d c)
    go WeightedPSQ [Weight] POption (Tree d c)
    cs)
        go (FChoice FN QPN
    qfn RevDepMap
    rdm c
    gr WeakOrTrivial
    t FlagType
    m Bool
    d WeightedPSQ [Weight] Bool (Tree d c)
    cs) =
          FN QPN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> FlagType
    -> Bool
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    forall d c.
    FN QPN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> FlagType
    -> Bool
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    FChoice FN QPN
    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))
    -> ReaderT ValidateState Identity (Tree d c)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Bool
     -> ReaderT ValidateState Identity (Tree d c)
     -> ReaderT ValidateState Identity (Tree d c))
    -> WeightedPSQ
         [Weight] Bool (ReaderT ValidateState Identity (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 (FN QPN
    -> Bool
    -> ReaderT ValidateState Identity (Tree d c)
    -> ReaderT ValidateState Identity (Tree d c)
    forall d c.
    FN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
    goF FN QPN
    qfn) ((Tree d c -> ReaderT ValidateState Identity (Tree d c))
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> WeightedPSQ
         [Weight] Bool (ReaderT ValidateState Identity (Tree d c))
    forall a b.
    (a -> b)
    -> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Tree d c -> ReaderT ValidateState Identity (Tree d c)
    forall d c. Tree d c -> Validate (Tree d c)
    go WeightedPSQ [Weight] Bool (Tree d c)
    cs)
        go (SChoice SN QPN
    qsn RevDepMap
    rdm c
    gr WeakOrTrivial
    t     WeightedPSQ [Weight] Bool (Tree d c)
    cs) =
          SN QPN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    forall d c.
    SN QPN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    SChoice SN QPN
    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))
    -> ReaderT ValidateState Identity (Tree d c)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Bool
     -> ReaderT ValidateState Identity (Tree d c)
     -> ReaderT ValidateState Identity (Tree d c))
    -> WeightedPSQ
         [Weight] Bool (ReaderT ValidateState Identity (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 (SN QPN
    -> Bool
    -> ReaderT ValidateState Identity (Tree d c)
    -> ReaderT ValidateState Identity (Tree d c)
    forall d c.
    SN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
    goS SN QPN
    qsn) ((Tree d c -> ReaderT ValidateState Identity (Tree d c))
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> WeightedPSQ
         [Weight] Bool (ReaderT ValidateState Identity (Tree d c))
    forall a b.
    (a -> b)
    -> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Tree d c -> ReaderT ValidateState Identity (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))
    -> ReaderT ValidateState Identity (Tree d c)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Tree d c -> ReaderT ValidateState Identity (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)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> PSQ (Goal QPN) a -> f (PSQ (Goal QPN) b)
    T.traverse Tree d c -> ReaderT ValidateState Identity (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 -> ReaderT ValidateState Identity (Tree d c)
    forall a. a -> ReaderT ValidateState Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Tree d c -> ReaderT ValidateState Identity (Tree d c))
    -> Tree d c -> ReaderT ValidateState Identity (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 -> ReaderT ValidateState Identity (Tree d c)
    forall a. a -> ReaderT ValidateState Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Tree d c -> ReaderT ValidateState Identity (Tree d c))
    -> Tree d c -> ReaderT ValidateState Identity (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 :: forall d c.
    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
          vs <- ReaderT ValidateState Identity ValidateState
    forall r (m :: * -> *). MonadReader r m => m r
    ask
          let PInfo deps _ _ _ = vsIndex vs ! pn ! i
              qdeps            = QualifyOptions -> QPN -> FlaggedDeps PackageName -> FlaggedDeps QPN
    qualifyDeps (ValidateState -> QualifyOptions
    vsQualifyOptions ValidateState
    vs) QPN
    qpn FlaggedDeps PackageName
    deps
              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 execUpdateState (pickPOption qpn opt qdeps) vs of
            Left  (ConflictSet
    cs, String
    err) -> Tree d c -> Validate (Tree d c)
    forall a. a -> ReaderT ValidateState Identity a
    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 a.
    (ValidateState -> ValidateState)
    -> ReaderT ValidateState Identity a
    -> ReaderT ValidateState Identity a
    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 = newSaved }) Validate (Tree d c)
    r

        -- Flag choices
        goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
        goF :: forall d c.
    FN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
    goF FN QPN
    qfn Bool
    b Validate (Tree d c)
    r = do
          vs <- ReaderT ValidateState Identity ValidateState
    forall r (m :: * -> *). MonadReader r m => m r
    ask
          case execUpdateState (pickFlag qfn b) vs of
            Left  (ConflictSet
    cs, String
    err) -> Tree d c -> Validate (Tree d c)
    forall a. a -> ReaderT ValidateState Identity a
    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 a.
    (ValidateState -> ValidateState)
    -> ReaderT ValidateState Identity a
    -> ReaderT ValidateState Identity a
    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 :: forall d c.
    SN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
    goS SN QPN
    qsn Bool
    b Validate (Tree d c)
    r = do
          vs <- ReaderT ValidateState Identity ValidateState
    forall r (m :: * -> *). MonadReader r m => m r
    ask
          case execUpdateState (pickStanza qsn b) vs of
            Left  (ConflictSet
    cs, String
    err) -> Tree d c -> Validate (Tree d c)
    forall a. a -> ReaderT ValidateState Identity a
    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 a.
    (ValidateState -> ValidateState)
    -> ReaderT ValidateState Identity a
    -> ReaderT ValidateState Identity a
    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 {
            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 {
        forall a. UpdateState a -> StateT ValidateState (Either Conflict) a
    unUpdateState :: StateT ValidateState (Either Conflict) a
      }
      deriving ((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
    $cfmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
    fmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
    $c<$ :: forall a b. a -> UpdateState b -> UpdateState a
    <$ :: forall a b. a -> UpdateState b -> UpdateState a
    Functor, Functor UpdateState
    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
    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
    $cpure :: forall a. a -> UpdateState a
    pure :: forall a. a -> UpdateState a
    $c<*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
    <*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
    $cliftA2 :: forall a b c.
    (a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
    liftA2 :: forall a b c.
    (a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
    $c*> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
    *> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
    $c<* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
    <* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
    Applicative, Applicative UpdateState
    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
    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
    $c>>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
    >>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
    $c>> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
    >> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
    $creturn :: forall a. a -> UpdateState a
    return :: forall a. a -> UpdateState a
    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 a. a -> StateT ValidateState (Either Conflict) a
    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' :: forall a. 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 (m :: * -> *) a. Monad m => m a -> StateT ValidateState m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift

    conflict :: Conflict -> UpdateState a
    conflict :: forall a. 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
        vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
        case M.lookup qpn (vsLinks 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
        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 = 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   = PackagePath -> PackageName -> QPN
    forall a. PackagePath -> a -> Qualified a
    Q PackagePath
    pp' PackageName
    pn
            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)
    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
        assert (sanityCheck (lgCanon lgTarget)) $ return ()

        -- Merge the two link groups (updateLinkGroup will propagate the change)
        lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget
        updateLinkGroup lgTarget'

        -- Make sure all dependencies are linked as well
        linkDeps target 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 = Just (PI pp 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'.
        rdeps <- FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
    requalify FlaggedDeps QPN
    deps
        go deps 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
            vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
            let 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 -> 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'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg'
            updateLinkGroup lg''
          (Flagged FN QPN
    fn FInfo
    _ FlaggedDeps QPN
    t FlaggedDeps QPN
    f, ~(Flagged FN QPN
    _ FInfo
    _ FlaggedDeps QPN
    t' FlaggedDeps QPN
    f')) -> do
            vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
            case M.lookup fn (vsFlags vs) of
              Maybe Bool
    Nothing    -> () -> UpdateState ()
    forall a. a -> UpdateState a
    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 SN QPN
    sn FlaggedDeps QPN
    t, ~(Stanza SN QPN
    _ FlaggedDeps QPN
    t')) -> do
            vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
            case M.lookup sn (vsStanzas vs) of
              Maybe Bool
    Nothing    -> () -> UpdateState ()
    forall a. a -> UpdateState a
    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 a. a -> UpdateState a
    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 a. a -> UpdateState a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          (Simple (LDep DependencyReason QPN
    _ (Lang Language
    _))   Component
    _, FlaggedDep QPN
    _) -> () -> UpdateState ()
    forall a. a -> UpdateState a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          (Simple (LDep DependencyReason QPN
    _ (Pkg  PkgconfigName
    _ PkgconfigVersionRange
    _)) Component
    _, FlaggedDep QPN
    _) -> () -> UpdateState ()
    forall a. a -> UpdateState a
    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
          vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
          return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)

    pickFlag :: QFN -> Bool -> UpdateState ()
    pickFlag :: FN QPN -> Bool -> UpdateState ()
    pickFlag FN QPN
    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 = M.insert qfn b (vsFlags vs) }
        FN QPN -> UpdateState ()
    verifyFlag FN QPN
    qfn
        Var QPN -> Bool -> UpdateState ()
    linkNewDeps (FN QPN -> Var QPN
    forall qpn. FN qpn -> Var qpn
    F FN QPN
    qfn) Bool
    b

    pickStanza :: QSN -> Bool -> UpdateState ()
    pickStanza :: SN QPN -> Bool -> UpdateState ()
    pickStanza SN QPN
    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 = M.insert qsn b (vsStanzas vs) }
        SN QPN -> UpdateState ()
    verifyStanza SN QPN
    qsn
        Var QPN -> Bool -> UpdateState ()
    linkNewDeps (SN QPN -> Var QPN
    forall qpn. SN qpn -> Var qpn
    S SN QPN
    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
        vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
        let qpn@(Q pp pn)           = varPN var
            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                      = 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                 = ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
    findNewDeps ValidateState
    vs FlaggedDeps QPN
    qdeps
            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)
        forM_ (S.toList linkedTo) $ \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 FN QPN
    qfn FInfo
    _ FlaggedDeps QPN
    t FlaggedDeps QPN
    f) =
          case (FN QPN -> Var QPN
    forall qpn. FN qpn -> Var qpn
    F FN QPN
    qfn Var QPN -> Var QPN -> Bool
    forall a. Eq a => a -> a -> Bool
    == Var QPN
    var, FN QPN -> FAssignment -> Maybe Bool
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup FN QPN
    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 SN QPN
    qsn FlaggedDeps QPN
    t) =
          case (SN QPN -> Var QPN
    forall qpn. SN qpn -> Var qpn
    S SN QPN
    qsn Var QPN -> Var QPN -> Bool
    forall a. Eq a => a -> a -> Bool
    == Var QPN
    var, SN QPN -> SAssignment -> Maybe Bool
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup SN QPN
    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 =           M.fromList (map aux (S.toList (lgMembers lg)))
                      `M.union` vsLinks 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 a. a -> UpdateState a
    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
            vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
            let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i
                flags   = FlagInfo -> [Flag]
    forall k a. Map k a -> [k]
    M.keys FlagInfo
    finfo
                stanzas = [OptionalStanza
    TestStanzas, OptionalStanza
    BenchStanzas]
            forM_ flags $ \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
            forM_ stanzas $ \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 :: FN QPN -> UpdateState ()
    verifyFlag (FN qpn :: QPN
    qpn@(Q PackagePath
    _pp PackageName
    pn) Flag
    fn) = do
        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
        verifyFlag' (FN pn fn) (vsLinks vs ! qpn)

    verifyStanza :: QSN -> UpdateState ()
    verifyStanza :: SN QPN -> UpdateState ()
    verifyStanza (SN qpn :: QPN
    qpn@(Q PackagePath
    _pp PackageName
    pn) OptionalStanza
    sn) = do
        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
        verifyStanza' (SN pn sn) (vsLinks vs ! 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
        vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
        let flags = (PackagePath -> FN QPN) -> [PackagePath] -> [FN QPN]
    forall a b. (a -> b) -> [a] -> [b]
    map (\PackagePath
    pp' -> QPN -> Flag -> FN QPN
    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  = (FN QPN -> Maybe Bool) -> [FN QPN] -> [Maybe Bool]
    forall a b. (a -> b) -> [a] -> [b]
    map (FN QPN -> FAssignment -> Maybe Bool
    forall k a. Ord k => k -> Map k a -> Maybe a
    `M.lookup` ValidateState -> FAssignment
    vsFlags ValidateState
    vs) [FN QPN]
    flags
        if allEqual (catMaybes vals) -- We ignore not-yet assigned flags
          then return ()
          else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg
                        , "flag \"" ++ unFlagName fn ++ "\" 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
        vs <- UpdateState ValidateState
    forall s (m :: * -> *). MonadState s m => m s
    get
        let stanzas = (PackagePath -> SN QPN) -> [PackagePath] -> [SN QPN]
    forall a b. (a -> b) -> [a] -> [b]
    map (\PackagePath
    pp' -> QPN -> OptionalStanza -> SN QPN
    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    = (SN QPN -> Maybe Bool) -> [SN QPN] -> [Maybe Bool]
    forall a b. (a -> b) -> [a] -> [b]
    map (SN QPN -> SAssignment -> Maybe Bool
    forall k a. Ord k => k -> Map k a -> Maybe a
    `M.lookup` ValidateState -> SAssignment
    vsStanzas ValidateState
    vs) [SN QPN]
    stanzas
        if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas
          then return ()
          else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg
                        , "stanza \"" ++ showStanza sn ++ "\" 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
    $cshowsPrec :: Int -> LinkGroup -> String -> String
    showsPrec :: Int -> LinkGroup -> String -> String
    $cshow :: LinkGroup -> String
    show :: LinkGroup -> String
    $cshowList :: [LinkGroup] -> String -> String
    showList :: [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
    $c== :: LinkGroup -> LinkGroup -> Bool
    == :: LinkGroup -> LinkGroup -> Bool
    $c/= :: LinkGroup -> LinkGroup -> Bool
    /= :: 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 a b. (a -> b) -> Maybe a -> Maybe b
    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 {
          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
        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')
        return LinkGroup {
            lgPackage = lgPackage lg
          , lgCanon   = canon
          , lgMembers = lgMembers lg `S.union` lgMembers lg'
          , lgBlame   = CS.unions [blame, lgBlame lg, lgBlame lg']
          }
      where
        pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
        pick :: forall a. Eq a => 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 :: forall a. Eq a => [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)