{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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)
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
, ValidateState -> Map QPN (FlaggedDeps QPN)
vsSaved :: Map QPN (FlaggedDeps QPN)
}
type Validate = Reader ValidateState
validateLinking :: Index -> Tree d c -> Tree d c
validateLinking :: forall d c. Index -> Tree d c -> Tree d c
validateLinking Index
index = (forall r a. Reader r a -> r -> a
`runReader` ValidateState
initVS) forall b c a. (b -> c) -> (a -> b) -> a -> 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) =
forall d c.
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
PChoice QPN
qpn RevDepMap
rdm c
gr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (forall d c.
QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP QPN
qpn) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) =
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (forall d c.
FN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF FN QPN
qfn) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) =
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (forall d c.
SN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS SN QPN
qsn) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
cs)
go (GoalChoice RevDepMap
rdm PSQ (Goal QPN) (Tree d c)
cs) = forall d c. RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
GoalChoice RevDepMap
rdm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse forall d c. Tree d c -> Validate (Tree d c)
go PSQ (Goal QPN) (Tree d c)
cs
go (Done RevDepMap
revDepMap d
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d c. RevDepMap -> d -> Tree d c
Done RevDepMap
revDepMap d
s
go (Fail ConflictSet
conflictSet FailReason
failReason) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
conflictSet FailReason
failReason
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
ValidateState
vs <- 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 forall k a. Ord k => Map k a -> k -> a
! PackageName
pn 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 = 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (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
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
ValidateState
vs <- forall r (m :: * -> *). MonadReader r m => m r
ask
case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (FN QPN -> Bool -> UpdateState ()
pickFlag FN QPN
qfn Bool
b) ValidateState
vs of
Left (ConflictSet
cs, String
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a b. a -> b -> a
const ValidateState
vs') Validate (Tree d c)
r
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
ValidateState
vs <- forall r (m :: * -> *). MonadReader r m => m r
ask
case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (SN QPN -> Bool -> UpdateState ()
pickStanza SN QPN
qsn Bool
b) ValidateState
vs of
Left (ConflictSet
cs, String
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (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 = forall k a. Map k a
M.empty
, vsFlags :: FAssignment
vsFlags = forall k a. Map k a
M.empty
, vsStanzas :: SAssignment
vsStanzas = forall k a. Map k a
M.empty
, vsQualifyOptions :: QualifyOptions
vsQualifyOptions = Index -> QualifyOptions
defaultQualifyOptions Index
index
, vsSaved :: Map QPN (FlaggedDeps QPN)
vsSaved = forall k a. Map k a
M.empty
}
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 -> 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
<$ :: forall a b. a -> UpdateState b -> UpdateState a
$c<$ :: forall a b. a -> UpdateState b -> UpdateState a
fmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
$cfmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
Functor, Functor 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
<* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
$c<* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
*> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
$c*> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
liftA2 :: forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
$cliftA2 :: forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
<*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
$c<*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
pure :: forall a. a -> UpdateState a
$cpure :: forall a. a -> UpdateState a
Applicative, Applicative 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
return :: forall a. a -> UpdateState a
$creturn :: forall a. a -> UpdateState a
>> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
$c>> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
>>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
$c>>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
Monad)
instance MonadState ValidateState UpdateState where
get :: UpdateState ValidateState
get = forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => m s
get
put :: ValidateState -> UpdateState ()
put ValidateState
st = forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState forall a b. (a -> b) -> a -> b
$ do
forall a. Bool -> a -> a
expensiveAssert (Map QPN LinkGroup -> Bool
lgInvariant forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
st) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
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' = forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Either Conflict a -> UpdateState a
lift' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall s (m :: * -> *). MonadState s m => m s
get
case 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 -> do
let lg :: LinkGroup
lg = QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall qpn. qpn -> I -> PI qpn
PI PackagePath
pp I
i)
LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg
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 <- forall s (m :: * -> *). MonadState s m => m s
get
let lgSource :: LinkGroup
lgSource = case 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 forall a. Maybe a
Nothing
Just LinkGroup
lg -> LinkGroup
lg
let target :: QPN
target = forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn
lgTarget :: LinkGroup
lgTarget = ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs forall k a. Ord k => Map k a -> k -> a
! QPN
target
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 forall a. Eq a => a -> a -> Bool
== LinkGroup -> PackageName
lgPackage LinkGroup
lgTarget Bool -> Bool -> Bool
&& I
i forall a. Eq a => a -> a -> Bool
== I
canonI
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe (PI PackagePath) -> Bool
sanityCheck (LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lgTarget)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
LinkGroup
lgTarget' <- forall a. Either Conflict a -> UpdateState a
lift' 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'
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
Just PI PackagePath
_ ->
forall a. Conflict -> UpdateState a
conflict ( Var QPN -> ConflictSet -> ConflictSet
CS.insert (forall qpn. qpn -> Var qpn
P QPN
qpn) (LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg)
, String
"cannot make " forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn
forall a. [a] -> [a] -> [a]
++ String
" canonical member of " 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 = forall a. a -> Maybe a
Just (forall qpn. qpn -> I -> PI qpn
PI PackagePath
pp I
i) }
LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg'
linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps QPN
target = \FlaggedDeps QPN
deps -> do
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 = 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 <- forall s (m :: * -> *). MonadState s m => m s
get
let lg :: LinkGroup
lg = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn forall a. Maybe a
Nothing) QPN
qpn forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
lg' :: LinkGroup
lg' = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn' forall a. Maybe a
Nothing) QPN
qpn' forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
LinkGroup
lg'' <- forall a. Either Conflict a -> UpdateState a
lift' forall a b. (a -> b) -> a -> b
$ ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ((ConflictSet -> ConflictSet -> ConflictSet
CS.union 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 FN QPN
fn FInfo
_ FlaggedDeps QPN
t FlaggedDeps QPN
f, ~(Flagged FN QPN
_ FInfo
_ FlaggedDeps QPN
t' FlaggedDeps QPN
f')) -> do
ValidateState
vs <- forall s (m :: * -> *). MonadState s m => m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FN QPN
fn (ValidateState -> FAssignment
vsFlags ValidateState
vs) of
Maybe Bool
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
ValidateState
vs <- forall s (m :: * -> *). MonadState s m => m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SN QPN
sn (ValidateState -> SAssignment
vsStanzas ValidateState
vs) of
Maybe Bool
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Bool
True -> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
t FlaggedDeps QPN
t'
Just Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Ext Extension
_)) Component
_, FlaggedDep QPN
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Lang Language
_)) Component
_, FlaggedDep QPN
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Pkg PkgconfigName
_ PkgconfigVersionRange
_)) Component
_, FlaggedDep QPN
_) -> 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 <- forall s (m :: * -> *). MonadState s m => m s
get
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: FN QPN -> Bool -> UpdateState ()
pickFlag FN QPN
qfn Bool
b = do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsFlags :: FAssignment
vsFlags = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FN QPN
qfn Bool
b (ValidateState -> FAssignment
vsFlags ValidateState
vs) }
FN QPN -> UpdateState ()
verifyFlag FN QPN
qfn
Var QPN -> Bool -> UpdateState ()
linkNewDeps (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
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsStanzas :: SAssignment
vsStanzas = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SN QPN
qsn Bool
b (ValidateState -> SAssignment
vsStanzas ValidateState
vs) }
SN QPN -> UpdateState ()
verifyStanza SN QPN
qsn
Var QPN -> Bool -> UpdateState ()
linkNewDeps (forall qpn. SN qpn -> Var qpn
S SN QPN
qsn) Bool
b
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps Var QPN
var Bool
b = do
ValidateState
vs <- forall s (m :: * -> *). MonadState s m => m s
get
let qpn :: QPN
qpn@(Q PackagePath
pp PackageName
pn) = forall qpn. Var qpn -> qpn
varPN Var QPN
var
qdeps :: FlaggedDeps QPN
qdeps = ValidateState -> Map QPN (FlaggedDeps QPN)
vsSaved ValidateState
vs forall k a. Ord k => Map k a -> k -> a
! QPN
qpn
lg :: LinkGroup
lg = ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs 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 = forall a. Ord a => a -> Set a -> Set a
S.delete PackagePath
pp (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Set a -> [a]
S.toList Set PackagePath
linkedTo) forall a b. (a -> b) -> a -> b
$ \PackagePath
pp' -> QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps (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 = 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 (forall qpn. FN qpn -> Var qpn
F FN QPN
qfn forall a. Eq a => a -> a -> Bool
== Var QPN
var, 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) -> []
(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 (forall qpn. SN qpn -> Var qpn
S SN QPN
qsn forall a. Eq a => a -> a -> Bool
== Var QPN
var, 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) -> []
(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
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs {
vsLinks :: Map QPN LinkGroup
vsLinks = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> (QPN, LinkGroup)
aux (forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)))
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 = (forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg), LinkGroup
lg)
verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup LinkGroup
lg =
case LinkGroup -> Maybe I
lgInstance LinkGroup
lg of
Maybe I
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just I
i -> do
ValidateState
vs <- 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 forall k a. Ord k => Map k a -> k -> a
! LinkGroup -> PackageName
lgPackage LinkGroup
lg forall k a. Ord k => Map k a -> k -> a
! I
i
flags :: [Flag]
flags = forall k a. Map k a -> [k]
M.keys FlagInfo
finfo
stanzas :: [OptionalStanza]
stanzas = [OptionalStanza
TestStanzas, OptionalStanza
BenchStanzas]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Flag]
flags forall a b. (a -> b) -> a -> b
$ \Flag
fn -> do
let flag :: FN PackageName
flag = forall qpn. qpn -> Flag -> FN qpn
FN (LinkGroup -> PackageName
lgPackage LinkGroup
lg) Flag
fn
FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' FN PackageName
flag LinkGroup
lg
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [OptionalStanza]
stanzas forall a b. (a -> b) -> a -> b
$ \OptionalStanza
sn -> do
let stanza :: SN PackageName
stanza = 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
ValidateState
vs <- forall s (m :: * -> *). MonadState s m => m s
get
FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' (forall qpn. qpn -> Flag -> FN qpn
FN PackageName
pn Flag
fn) (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs forall k a. Ord k => Map k a -> k -> a
! QPN
qpn)
verifyStanza :: QSN -> UpdateState ()
verifyStanza :: SN QPN -> UpdateState ()
verifyStanza (SN qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) OptionalStanza
sn) = do
ValidateState
vs <- forall s (m :: * -> *). MonadState s m => m s
get
SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' (forall qpn. qpn -> OptionalStanza -> SN qpn
SN PackageName
pn OptionalStanza
sn) (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs forall k a. Ord k => Map k a -> k -> a
! QPN
qpn)
verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
verifyFlag' :: FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' (FN PackageName
pn Flag
fn) LinkGroup
lg = do
ValidateState
vs <- forall s (m :: * -> *). MonadState s m => m s
get
let flags :: [FN QPN]
flags = forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> forall qpn. qpn -> Flag -> FN qpn
FN (forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) Flag
fn) (forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
vals :: [Maybe Bool]
vals = forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> FAssignment
vsFlags ValidateState
vs) [FN QPN]
flags
if forall a. Eq a => [a] -> Bool
allEqual (forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals)
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall qpn. FN qpn -> Var qpn
F [FN QPN]
flags) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
, String
"flag \"" forall a. [a] -> [a] -> [a]
++ Flag -> String
unFlagName Flag
fn forall a. [a] -> [a] -> [a]
++ String
"\" incompatible"
)
verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
verifyStanza' :: SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' (SN PackageName
pn OptionalStanza
sn) LinkGroup
lg = do
ValidateState
vs <- forall s (m :: * -> *). MonadState s m => m s
get
let stanzas :: [SN QPN]
stanzas = forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> forall qpn. qpn -> OptionalStanza -> SN qpn
SN (forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) OptionalStanza
sn) (forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
vals :: [Maybe Bool]
vals = forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> SAssignment
vsStanzas ValidateState
vs) [SN QPN]
stanzas
if forall a. Eq a => [a] -> Bool
allEqual (forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals)
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall qpn. SN qpn -> Var qpn
S [SN QPN]
stanzas) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
, String
"stanza \"" forall a. [a] -> [a] -> [a]
++ OptionalStanza -> String
showStanza OptionalStanza
sn forall a. [a] -> [a] -> [a]
++ String
"\" incompatible"
)
data LinkGroup = LinkGroup {
LinkGroup -> PackageName
lgPackage :: PN
, LinkGroup -> Maybe (PI PackagePath)
lgCanon :: Maybe (PI PackagePath)
, LinkGroup -> Set PackagePath
lgMembers :: Set PackagePath
, LinkGroup -> ConflictSet
lgBlame :: ConflictSet
}
deriving (Int -> LinkGroup -> ShowS
[LinkGroup] -> ShowS
LinkGroup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinkGroup] -> ShowS
$cshowList :: [LinkGroup] -> ShowS
show :: LinkGroup -> String
$cshow :: LinkGroup -> String
showsPrec :: Int -> LinkGroup -> ShowS
$cshowsPrec :: Int -> LinkGroup -> ShowS
Show, LinkGroup -> LinkGroup -> Bool
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)
lgInvariant :: Map QPN LinkGroup -> Bool
lgInvariant :: Map QPN LinkGroup -> Bool
lgInvariant Map QPN LinkGroup
links = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LinkGroup -> Bool
invGroup (forall k a. Map k a -> [a]
M.elems Map QPN LinkGroup
links)
where
invGroup :: LinkGroup -> Bool
invGroup :: LinkGroup -> Bool
invGroup LinkGroup
lg = forall a. Eq a => [a] -> Bool
allEqual forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. PackagePath -> a -> Qualified a
`Q` LinkGroup -> PackageName
lgPackage LinkGroup
lg) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)
lgInstance :: LinkGroup -> Maybe I
lgInstance :: LinkGroup -> Maybe I
lgInstance = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PI PackagePath
_ I
i) -> I
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
"{" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> String
showMember (forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))) 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 forall a. Eq a => a -> a -> Bool
== PackagePath
pp' -> String
"*"
Maybe (PI PackagePath)
_otherwise -> 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 (forall qpn. qpn -> I -> PI qpn
PI (PackagePath -> QPN
qpn PackagePath
pp) I
i)
qpn :: PackagePath -> QPN
qpn :: PackagePath -> QPN
qpn PackagePath
pp = forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg)
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 = 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 <- 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')
forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 :: forall a. Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
pick Maybe a
Nothing Maybe a
Nothing = forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
pick (Just a
x) Maybe a
Nothing = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
pick Maybe a
Nothing (Just a
y) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
y
pick (Just a
x) (Just a
y) =
if a
x forall a. Eq a => a -> a -> Bool
== a
y then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
else 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 " forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg
forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg'
)
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg =
[Var QPN] -> ConflictSet
CS.fromList (forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> Var QPN
aux (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 = forall qpn. qpn -> Var qpn
P (forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg))
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 forall a. Eq a => a -> a -> Bool
== a
y Bool -> Bool -> Bool
&& forall a. Eq a => [a] -> Bool
allEqual (a
yforall a. a -> [a] -> [a]
:[a]
ys)