{-# 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.Reader
import Control.Monad.State
import Data.Map ((!))
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Traversable as T
import Distribution.Client.Utils.Assertion
import Distribution.Solver.Modular.Assignment
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import Distribution.Types.Flag (unFlagName)
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 :: Index -> Tree d c -> Tree d c
validateLinking Index
index = (Reader ValidateState (Tree d c) -> ValidateState -> Tree d c
forall r a. Reader r a -> r -> a
`runReader` ValidateState
initVS) (Reader ValidateState (Tree d c) -> Tree d c)
-> (Tree d c -> Reader ValidateState (Tree d c))
-> Tree d c
-> Tree d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d c -> Reader ValidateState (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go
where
go :: Tree d c -> Validate (Tree d c)
go :: Tree d c -> Validate (Tree d c)
go (PChoice QPN
qpn RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Tree d c)
cs) =
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
forall d c.
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
PChoice QPN
qpn RevDepMap
rdm c
gr (WeightedPSQ [Weight] POption (Tree d c) -> Tree d c)
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((POption -> Validate (Tree d c) -> Validate (Tree d c))
-> WeightedPSQ [Weight] POption (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP QPN
qpn) (WeightedPSQ [Weight] POption (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c)))
-> WeightedPSQ [Weight] POption (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Validate (Tree d c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] POption (Tree d c)
cs)
go (FChoice QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
t FlagType
m Bool
d WeightedPSQ [Weight] Bool (Tree d c)
cs) =
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
FChoice QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
t FlagType
m Bool
d (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool -> Validate (Tree d c) -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF QFN
qfn) (WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c)))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
cs)
go (SChoice QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
t WeightedPSQ [Weight] Bool (Tree d c)
cs) =
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
SChoice QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
t (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool -> Validate (Tree d c) -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
forall d c.
QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS QSN
qsn) (WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c)))
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> Validate (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Validate (Tree d c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
cs)
go (GoalChoice RevDepMap
rdm PSQ (Goal QPN) (Tree d c)
cs) = RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
forall d c. RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
GoalChoice RevDepMap
rdm (PSQ (Goal QPN) (Tree d c) -> Tree d c)
-> ReaderT ValidateState Identity (PSQ (Goal QPN) (Tree d c))
-> Validate (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree d c -> Validate (Tree d c))
-> PSQ (Goal QPN) (Tree d c)
-> ReaderT ValidateState Identity (PSQ (Goal QPN) (Tree d c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse Tree d c -> Validate (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go PSQ (Goal QPN) (Tree d c)
cs
go (Done RevDepMap
revDepMap d
s) = Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ RevDepMap -> d -> Tree d c
forall d c. RevDepMap -> d -> Tree d c
Done RevDepMap
revDepMap d
s
go (Fail ConflictSet
conflictSet FailReason
failReason) = Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
conflictSet FailReason
failReason
goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) opt :: POption
opt@(POption I
i Maybe PackagePath
_) Validate (Tree d c)
r = do
ValidateState
vs <- ReaderT ValidateState Identity ValidateState
forall r (m :: * -> *). MonadReader r m => m r
ask
let PInfo FlaggedDeps PackageName
deps Map ExposedComponent ComponentInfo
_ FlagInfo
_ Maybe FailReason
_ = ValidateState -> Index
vsIndex ValidateState
vs Index -> PackageName -> Map I PInfo
forall k a. Ord k => Map k a -> k -> a
! PackageName
pn Map I PInfo -> I -> PInfo
forall k a. Ord k => Map k a -> k -> a
! I
i
qdeps :: FlaggedDeps QPN
qdeps = QualifyOptions -> QPN -> FlaggedDeps PackageName -> FlaggedDeps QPN
qualifyDeps (ValidateState -> QualifyOptions
vsQualifyOptions ValidateState
vs) QPN
qpn FlaggedDeps PackageName
deps
newSaved :: Map QPN (FlaggedDeps QPN)
newSaved = QPN
-> FlaggedDeps QPN
-> Map QPN (FlaggedDeps QPN)
-> Map QPN (FlaggedDeps QPN)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QPN
qpn FlaggedDeps QPN
qdeps (ValidateState -> Map QPN (FlaggedDeps QPN)
vsSaved ValidateState
vs)
case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption QPN
qpn POption
opt FlaggedDeps QPN
qdeps) ValidateState
vs of
Left (ConflictSet
cs, String
err) -> Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ValidateState -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs' { vsSaved :: Map QPN (FlaggedDeps QPN)
vsSaved = Map QPN (FlaggedDeps QPN)
newSaved }) Validate (Tree d c)
r
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF QFN
qfn Bool
b Validate (Tree d c)
r = do
ValidateState
vs <- ReaderT ValidateState Identity ValidateState
forall r (m :: * -> *). MonadReader r m => m r
ask
case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (QFN -> Bool -> UpdateState ()
pickFlag QFN
qfn Bool
b) ValidateState
vs of
Left (ConflictSet
cs, String
err) -> Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ValidateState -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs') Validate (Tree d c)
r
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS QSN
qsn Bool
b Validate (Tree d c)
r = do
ValidateState
vs <- ReaderT ValidateState Identity ValidateState
forall r (m :: * -> *). MonadReader r m => m r
ask
case UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState (QSN -> Bool -> UpdateState ()
pickStanza QSN
qsn Bool
b) ValidateState
vs of
Left (ConflictSet
cs, String
err) -> Tree d c -> Validate (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ValidateState -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs') Validate (Tree d c)
r
initVS :: ValidateState
initVS :: ValidateState
initVS = VS :: Index
-> Map QPN LinkGroup
-> FAssignment
-> SAssignment
-> QualifyOptions
-> Map QPN (FlaggedDeps QPN)
-> ValidateState
VS {
vsIndex :: Index
vsIndex = Index
index
, vsLinks :: Map QPN LinkGroup
vsLinks = Map QPN LinkGroup
forall k a. Map k a
M.empty
, vsFlags :: FAssignment
vsFlags = FAssignment
forall k a. Map k a
M.empty
, vsStanzas :: SAssignment
vsStanzas = SAssignment
forall k a. Map k a
M.empty
, vsQualifyOptions :: QualifyOptions
vsQualifyOptions = Index -> QualifyOptions
defaultQualifyOptions Index
index
, vsSaved :: Map QPN (FlaggedDeps QPN)
vsSaved = Map QPN (FlaggedDeps QPN)
forall k a. Map k a
M.empty
}
type Conflict = (ConflictSet, String)
newtype UpdateState a = UpdateState {
UpdateState a -> StateT ValidateState (Either Conflict) a
unUpdateState :: StateT ValidateState (Either Conflict) a
}
deriving (a -> UpdateState b -> UpdateState a
(a -> b) -> UpdateState a -> UpdateState b
(forall a b. (a -> b) -> UpdateState a -> UpdateState b)
-> (forall a b. a -> UpdateState b -> UpdateState a)
-> Functor UpdateState
forall a b. a -> UpdateState b -> UpdateState a
forall a b. (a -> b) -> UpdateState a -> UpdateState b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> UpdateState b -> UpdateState a
$c<$ :: forall a b. a -> UpdateState b -> UpdateState a
fmap :: (a -> b) -> UpdateState a -> UpdateState b
$cfmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
Functor, Functor UpdateState
a -> UpdateState a
Functor UpdateState
-> (forall a. a -> UpdateState a)
-> (forall a b.
UpdateState (a -> b) -> UpdateState a -> UpdateState b)
-> (forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState b)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState a)
-> Applicative UpdateState
UpdateState a -> UpdateState b -> UpdateState b
UpdateState a -> UpdateState b -> UpdateState a
UpdateState (a -> b) -> UpdateState a -> UpdateState b
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
forall a. a -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState b
forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: UpdateState a -> UpdateState b -> UpdateState a
$c<* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
*> :: UpdateState a -> UpdateState b -> UpdateState b
$c*> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
liftA2 :: (a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
$cliftA2 :: forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
<*> :: UpdateState (a -> b) -> UpdateState a -> UpdateState b
$c<*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
pure :: a -> UpdateState a
$cpure :: forall a. a -> UpdateState a
$cp1Applicative :: Functor UpdateState
Applicative, Applicative UpdateState
a -> UpdateState a
Applicative UpdateState
-> (forall a b.
UpdateState a -> (a -> UpdateState b) -> UpdateState b)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState b)
-> (forall a. a -> UpdateState a)
-> Monad UpdateState
UpdateState a -> (a -> UpdateState b) -> UpdateState b
UpdateState a -> UpdateState b -> UpdateState b
forall a. a -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState b
forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> UpdateState a
$creturn :: forall a. a -> UpdateState a
>> :: UpdateState a -> UpdateState b -> UpdateState b
$c>> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
>>= :: UpdateState a -> (a -> UpdateState b) -> UpdateState b
$c>>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
$cp1Monad :: Applicative UpdateState
Monad)
instance MonadState ValidateState UpdateState where
get :: UpdateState ValidateState
get = StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState)
-> StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState
forall a b. (a -> b) -> a -> b
$ StateT ValidateState (Either Conflict) ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
put :: ValidateState -> UpdateState ()
put ValidateState
st = StateT ValidateState (Either Conflict) () -> UpdateState ()
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) () -> UpdateState ())
-> StateT ValidateState (Either Conflict) () -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ do
Bool
-> StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ()
forall a. Bool -> a -> a
expensiveAssert (Map QPN LinkGroup -> Bool
lgInvariant (Map QPN LinkGroup -> Bool) -> Map QPN LinkGroup -> Bool
forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
st) (StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ())
-> StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ()
forall a b. (a -> b) -> a -> b
$ () -> StateT ValidateState (Either Conflict) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ValidateState -> StateT ValidateState (Either Conflict) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ValidateState
st
lift' :: Either Conflict a -> UpdateState a
lift' :: Either Conflict a -> UpdateState a
lift' = StateT ValidateState (Either Conflict) a -> UpdateState a
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) a -> UpdateState a)
-> (Either Conflict a -> StateT ValidateState (Either Conflict) a)
-> Either Conflict a
-> UpdateState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Conflict a -> StateT ValidateState (Either Conflict) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
conflict :: Conflict -> UpdateState a
conflict :: Conflict -> UpdateState a
conflict = Either Conflict a -> UpdateState a
forall a. Either Conflict a -> UpdateState a
lift' (Either Conflict a -> UpdateState a)
-> (Conflict -> Either Conflict a) -> Conflict -> UpdateState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conflict -> Either Conflict a
forall a b. a -> Either a b
Left
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState = StateT ValidateState (Either Conflict) ()
-> ValidateState -> Either Conflict ValidateState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT ValidateState (Either Conflict) ()
-> ValidateState -> Either Conflict ValidateState)
-> (UpdateState () -> StateT ValidateState (Either Conflict) ())
-> UpdateState ()
-> ValidateState
-> Either Conflict ValidateState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateState () -> StateT ValidateState (Either Conflict) ()
forall a. UpdateState a -> StateT ValidateState (Either Conflict) a
unUpdateState
pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption QPN
qpn (POption I
i Maybe PackagePath
Nothing) FlaggedDeps QPN
_deps = QPN -> I -> UpdateState ()
pickConcrete QPN
qpn I
i
pickPOption QPN
qpn (POption I
i (Just PackagePath
pp')) FlaggedDeps QPN
deps = QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
pickLink QPN
qpn I
i PackagePath
pp' FlaggedDeps QPN
deps
pickConcrete :: QPN -> I -> UpdateState ()
pickConcrete :: QPN -> I -> UpdateState ()
pickConcrete qpn :: QPN
qpn@(Q PackagePath
pp PackageName
_) I
i = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
case QPN -> Map QPN LinkGroup -> Maybe LinkGroup
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QPN
qpn (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs) of
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
Just LinkGroup
lg ->
LinkGroup -> QPN -> I -> UpdateState ()
makeCanonical LinkGroup
lg QPN
qpn I
i
pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
pickLink qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) I
i PackagePath
pp' FlaggedDeps QPN
deps = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
let lgSource :: LinkGroup
lgSource = case QPN -> Map QPN LinkGroup -> Maybe LinkGroup
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QPN
qpn (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs) of
Maybe LinkGroup
Nothing -> QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn Maybe (PI PackagePath)
forall a. Maybe a
Nothing
Just LinkGroup
lg -> LinkGroup
lg
let target :: QPN
target = PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn
lgTarget :: LinkGroup
lgTarget = ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
target
let sanityCheck :: Maybe (PI PackagePath) -> Bool
sanityCheck :: Maybe (PI PackagePath) -> Bool
sanityCheck Maybe (PI PackagePath)
Nothing = Bool
False
sanityCheck (Just (PI PackagePath
_ I
canonI)) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== LinkGroup -> PackageName
lgPackage LinkGroup
lgTarget Bool -> Bool -> Bool
&& I
i I -> I -> Bool
forall a. Eq a => a -> a -> Bool
== I
canonI
Bool -> UpdateState () -> UpdateState ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe (PI PackagePath) -> Bool
sanityCheck (LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lgTarget)) (UpdateState () -> UpdateState ())
-> UpdateState () -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LinkGroup
lgTarget' <- Either Conflict LinkGroup -> UpdateState LinkGroup
forall a. Either Conflict a -> UpdateState a
lift' (Either Conflict LinkGroup -> UpdateState LinkGroup)
-> Either Conflict LinkGroup -> UpdateState LinkGroup
forall a b. (a -> b) -> a -> b
$ ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ConflictSet
CS.empty LinkGroup
lgSource LinkGroup
lgTarget
LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lgTarget'
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
_ ->
Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( Var QPN -> ConflictSet -> ConflictSet
CS.insert (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn) (LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg)
, String
"cannot make " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" canonical member of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg
)
Maybe (PI PackagePath)
Nothing -> do
let lg' :: LinkGroup
lg' = LinkGroup
lg { lgCanon :: Maybe (PI PackagePath)
lgCanon = PI PackagePath -> Maybe (PI PackagePath)
forall a. a -> Maybe a
Just (PackagePath -> I -> PI PackagePath
forall qpn. qpn -> I -> PI qpn
PI PackagePath
pp I
i) }
LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg'
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 = (FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ())
-> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
go1
go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
go1 FlaggedDep QPN
dep FlaggedDep QPN
rdep = case (FlaggedDep QPN
dep, FlaggedDep QPN
rdep) of
(Simple (LDep DependencyReason QPN
dr1 (Dep (PkgComponent QPN
qpn ExposedComponent
_) CI
_)) Component
_, ~(Simple (LDep DependencyReason QPN
dr2 (Dep (PkgComponent QPN
qpn' ExposedComponent
_) CI
_)) Component
_)) -> do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
let lg :: LinkGroup
lg = LinkGroup -> QPN -> Map QPN LinkGroup -> LinkGroup
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn Maybe (PI PackagePath)
forall a. Maybe a
Nothing) QPN
qpn (Map QPN LinkGroup -> LinkGroup) -> Map QPN LinkGroup -> LinkGroup
forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
lg' :: LinkGroup
lg' = LinkGroup -> QPN -> Map QPN LinkGroup -> LinkGroup
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton QPN
qpn' Maybe (PI PackagePath)
forall a. Maybe a
Nothing) QPN
qpn' (Map QPN LinkGroup -> LinkGroup) -> Map QPN LinkGroup -> LinkGroup
forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
LinkGroup
lg'' <- Either Conflict LinkGroup -> UpdateState LinkGroup
forall a. Either Conflict a -> UpdateState a
lift' (Either Conflict LinkGroup -> UpdateState LinkGroup)
-> Either Conflict LinkGroup -> UpdateState LinkGroup
forall a b. (a -> b) -> a -> b
$ ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ((ConflictSet -> ConflictSet -> ConflictSet
CS.union (ConflictSet -> ConflictSet -> ConflictSet)
-> (DependencyReason QPN -> ConflictSet)
-> DependencyReason QPN
-> DependencyReason QPN
-> ConflictSet
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet) DependencyReason QPN
dr1 DependencyReason QPN
dr2) LinkGroup
lg LinkGroup
lg'
LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg''
(Flagged QFN
fn FInfo
_ FlaggedDeps QPN
t FlaggedDeps QPN
f, ~(Flagged QFN
_ FInfo
_ FlaggedDeps QPN
t' FlaggedDeps QPN
f')) -> do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
case QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QFN
fn (ValidateState -> FAssignment
vsFlags ValidateState
vs) of
Maybe Bool
Nothing -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Bool
True -> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
t FlaggedDeps QPN
t'
Just Bool
False -> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
f FlaggedDeps QPN
f'
(Stanza QSN
sn FlaggedDeps QPN
t, ~(Stanza QSN
_ FlaggedDeps QPN
t')) -> do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
case QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QSN
sn (ValidateState -> SAssignment
vsStanzas ValidateState
vs) of
Maybe Bool
Nothing -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Bool
True -> FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
go FlaggedDeps QPN
t FlaggedDeps QPN
t'
Just Bool
False -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Ext Extension
_)) Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Lang Language
_)) Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Pkg PkgconfigName
_ PkgconfigVersionRange
_)) Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify FlaggedDeps QPN
deps = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
forall (m :: * -> *) a. Monad m => a -> m a
return (FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN))
-> FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
forall a b. (a -> b) -> a -> b
$ QualifyOptions -> QPN -> FlaggedDeps PackageName -> FlaggedDeps QPN
qualifyDeps (ValidateState -> QualifyOptions
vsQualifyOptions ValidateState
vs) QPN
target (FlaggedDeps QPN -> FlaggedDeps PackageName
unqualifyDeps FlaggedDeps QPN
deps)
pickFlag :: QFN -> Bool -> UpdateState ()
pickFlag :: QFN -> Bool -> UpdateState ()
pickFlag QFN
qfn Bool
b = do
(ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsFlags :: FAssignment
vsFlags = QFN -> Bool -> FAssignment -> FAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QFN
qfn Bool
b (ValidateState -> FAssignment
vsFlags ValidateState
vs) }
QFN -> UpdateState ()
verifyFlag QFN
qfn
Var QPN -> Bool -> UpdateState ()
linkNewDeps (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn) Bool
b
pickStanza :: QSN -> Bool -> UpdateState ()
pickStanza :: QSN -> Bool -> UpdateState ()
pickStanza QSN
qsn Bool
b = do
(ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsStanzas :: SAssignment
vsStanzas = QSN -> Bool -> SAssignment -> SAssignment
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QSN
qsn Bool
b (ValidateState -> SAssignment
vsStanzas ValidateState
vs) }
QSN -> UpdateState ()
verifyStanza QSN
qsn
Var QPN -> Bool -> UpdateState ()
linkNewDeps (QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn) Bool
b
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps Var QPN
var Bool
b = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
let qpn :: QPN
qpn@(Q PackagePath
pp PackageName
pn) = Var QPN -> QPN
forall qpn. Var qpn -> qpn
varPN Var QPN
var
qdeps :: FlaggedDeps QPN
qdeps = ValidateState -> Map QPN (FlaggedDeps QPN)
vsSaved ValidateState
vs Map QPN (FlaggedDeps QPN) -> QPN -> FlaggedDeps QPN
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn
lg :: LinkGroup
lg = ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn
newDeps :: FlaggedDeps QPN
newDeps = ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs FlaggedDeps QPN
qdeps
linkedTo :: Set PackagePath
linkedTo = PackagePath -> Set PackagePath -> Set PackagePath
forall a. Ord a => a -> Set a -> Set a
S.delete PackagePath
pp (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)
[PackagePath] -> (PackagePath -> UpdateState ()) -> UpdateState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList Set PackagePath
linkedTo) ((PackagePath -> UpdateState ()) -> UpdateState ())
-> (PackagePath -> UpdateState ()) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \PackagePath
pp' -> QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) FlaggedDeps QPN
newDeps
where
findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs = (FlaggedDep QPN -> FlaggedDeps QPN)
-> FlaggedDeps QPN -> FlaggedDeps QPN
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
findNewDeps' ValidateState
vs)
findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
findNewDeps' ValidateState
_ (Simple LDep QPN
_ Component
_) = []
findNewDeps' ValidateState
vs (Flagged QFN
qfn FInfo
_ FlaggedDeps QPN
t FlaggedDeps QPN
f) =
case (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== Var QPN
var, QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QFN
qfn (ValidateState -> FAssignment
vsFlags ValidateState
vs)) of
(Bool
True, Maybe Bool
_) -> if Bool
b then FlaggedDeps QPN
t else FlaggedDeps QPN
f
(Bool
_, Maybe Bool
Nothing) -> []
(Bool
_, Just Bool
b') -> ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs (if Bool
b' then FlaggedDeps QPN
t else FlaggedDeps QPN
f)
findNewDeps' ValidateState
vs (Stanza QSN
qsn FlaggedDeps QPN
t) =
case (QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== Var QPN
var, QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QSN
qsn (ValidateState -> SAssignment
vsStanzas ValidateState
vs)) of
(Bool
True, Maybe Bool
_) -> if Bool
b then FlaggedDeps QPN
t else []
(Bool
_, Maybe Bool
Nothing) -> []
(Bool
_, Just Bool
b') -> ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs (if Bool
b' then FlaggedDeps QPN
t else [])
updateLinkGroup :: LinkGroup -> UpdateState ()
updateLinkGroup :: LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg = do
LinkGroup -> UpdateState ()
verifyLinkGroup LinkGroup
lg
(ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs {
vsLinks :: Map QPN LinkGroup
vsLinks = [(QPN, LinkGroup)] -> Map QPN LinkGroup
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((PackagePath -> (QPN, LinkGroup))
-> [PackagePath] -> [(QPN, LinkGroup)]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> (QPN, LinkGroup)
aux (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)))
Map QPN LinkGroup -> Map QPN LinkGroup -> Map QPN LinkGroup
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs
}
where
aux :: PackagePath -> (QPN, LinkGroup)
aux PackagePath
pp = (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg), LinkGroup
lg)
verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup LinkGroup
lg =
case LinkGroup -> Maybe I
lgInstance LinkGroup
lg of
Maybe I
Nothing ->
() -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just I
i -> do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
let PInfo FlaggedDeps PackageName
_deps Map ExposedComponent ComponentInfo
_exes FlagInfo
finfo Maybe FailReason
_ = ValidateState -> Index
vsIndex ValidateState
vs Index -> PackageName -> Map I PInfo
forall k a. Ord k => Map k a -> k -> a
! LinkGroup -> PackageName
lgPackage LinkGroup
lg Map I PInfo -> I -> PInfo
forall k a. Ord k => Map k a -> k -> a
! I
i
flags :: [Flag]
flags = FlagInfo -> [Flag]
forall k a. Map k a -> [k]
M.keys FlagInfo
finfo
stanzas :: [OptionalStanza]
stanzas = [OptionalStanza
TestStanzas, OptionalStanza
BenchStanzas]
[Flag] -> (Flag -> UpdateState ()) -> UpdateState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Flag]
flags ((Flag -> UpdateState ()) -> UpdateState ())
-> (Flag -> UpdateState ()) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \Flag
fn -> do
let flag :: FN PackageName
flag = PackageName -> Flag -> FN PackageName
forall qpn. qpn -> Flag -> FN qpn
FN (LinkGroup -> PackageName
lgPackage LinkGroup
lg) Flag
fn
FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' FN PackageName
flag LinkGroup
lg
[OptionalStanza]
-> (OptionalStanza -> UpdateState ()) -> UpdateState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [OptionalStanza]
stanzas ((OptionalStanza -> UpdateState ()) -> UpdateState ())
-> (OptionalStanza -> UpdateState ()) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \OptionalStanza
sn -> do
let stanza :: SN PackageName
stanza = PackageName -> OptionalStanza -> SN PackageName
forall qpn. qpn -> OptionalStanza -> SN qpn
SN (LinkGroup -> PackageName
lgPackage LinkGroup
lg) OptionalStanza
sn
SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' SN PackageName
stanza LinkGroup
lg
verifyFlag :: QFN -> UpdateState ()
verifyFlag :: QFN -> UpdateState ()
verifyFlag (FN qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) Flag
fn) = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' (PackageName -> Flag -> FN PackageName
forall qpn. qpn -> Flag -> FN qpn
FN PackageName
pn Flag
fn) (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn)
verifyStanza :: QSN -> UpdateState ()
verifyStanza :: QSN -> UpdateState ()
verifyStanza (SN qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) OptionalStanza
sn) = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' (PackageName -> OptionalStanza -> SN PackageName
forall qpn. qpn -> OptionalStanza -> SN qpn
SN PackageName
pn OptionalStanza
sn) (ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
vs Map QPN LinkGroup -> QPN -> LinkGroup
forall k a. Ord k => Map k a -> k -> a
! QPN
qpn)
verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
verifyFlag' :: FN PackageName -> LinkGroup -> UpdateState ()
verifyFlag' (FN PackageName
pn Flag
fn) LinkGroup
lg = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
let flags :: [QFN]
flags = (PackagePath -> QFN) -> [PackagePath] -> [QFN]
forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> QPN -> Flag -> QFN
forall qpn. qpn -> Flag -> FN qpn
FN (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) Flag
fn) (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
vals :: [Maybe Bool]
vals = (QFN -> Maybe Bool) -> [QFN] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (QFN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> FAssignment
vsFlags ValidateState
vs) [QFN]
flags
if [Bool] -> Bool
forall a. Eq a => [a] -> Bool
allEqual ([Maybe Bool] -> [Bool]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals)
then () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList ((QFN -> Var QPN) -> [QFN] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F [QFN]
flags) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
, String
"flag \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Flag -> String
unFlagName Flag
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" incompatible"
)
verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
verifyStanza' :: SN PackageName -> LinkGroup -> UpdateState ()
verifyStanza' (SN PackageName
pn OptionalStanza
sn) LinkGroup
lg = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
let stanzas :: [QSN]
stanzas = (PackagePath -> QSN) -> [PackagePath] -> [QSN]
forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> QPN -> OptionalStanza -> QSN
forall qpn. qpn -> OptionalStanza -> SN qpn
SN (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) OptionalStanza
sn) (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
vals :: [Maybe Bool]
vals = (QSN -> Maybe Bool) -> [QSN] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (QSN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> SAssignment
vsStanzas ValidateState
vs) [QSN]
stanzas
if [Bool] -> Bool
forall a. Eq a => [a] -> Bool
allEqual ([Maybe Bool] -> [Bool]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals)
then () -> UpdateState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList ((QSN -> Var QPN) -> [QSN] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S [QSN]
stanzas) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
, String
"stanza \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionalStanza -> String
showStanza OptionalStanza
sn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" incompatible"
)
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 -> String -> String
[LinkGroup] -> String -> String
LinkGroup -> String
(Int -> LinkGroup -> String -> String)
-> (LinkGroup -> String)
-> ([LinkGroup] -> String -> String)
-> Show LinkGroup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LinkGroup] -> String -> String
$cshowList :: [LinkGroup] -> String -> String
show :: LinkGroup -> String
$cshow :: LinkGroup -> String
showsPrec :: Int -> LinkGroup -> String -> String
$cshowsPrec :: Int -> LinkGroup -> String -> String
Show, LinkGroup -> LinkGroup -> Bool
(LinkGroup -> LinkGroup -> Bool)
-> (LinkGroup -> LinkGroup -> Bool) -> Eq LinkGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinkGroup -> LinkGroup -> Bool
$c/= :: LinkGroup -> LinkGroup -> Bool
== :: LinkGroup -> LinkGroup -> Bool
$c== :: LinkGroup -> LinkGroup -> Bool
Eq)
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)
lgInstance :: LinkGroup -> Maybe I
lgInstance :: LinkGroup -> Maybe I
lgInstance = (PI PackagePath -> I) -> Maybe (PI PackagePath) -> Maybe I
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PI PackagePath
_ I
i) -> I
i) (Maybe (PI PackagePath) -> Maybe I)
-> (LinkGroup -> Maybe (PI PackagePath)) -> LinkGroup -> Maybe I
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkGroup -> Maybe (PI PackagePath)
lgCanon
showLinkGroup :: LinkGroup -> String
showLinkGroup :: LinkGroup -> String
showLinkGroup LinkGroup
lg =
String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((PackagePath -> String) -> [PackagePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> String
showMember (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
where
showMember :: PackagePath -> String
showMember :: PackagePath -> String
showMember PackagePath
pp = case LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg of
Just (PI PackagePath
pp' I
_i) | PackagePath
pp PackagePath -> PackagePath -> Bool
forall a. Eq a => a -> a -> Bool
== PackagePath
pp' -> String
"*"
Maybe (PI PackagePath)
_otherwise -> String
""
String -> String -> String
forall a. [a] -> [a] -> [a]
++ case LinkGroup -> Maybe I
lgInstance LinkGroup
lg of
Maybe I
Nothing -> QPN -> String
showQPN (PackagePath -> QPN
qpn PackagePath
pp)
Just I
i -> PI QPN -> String
showPI (QPN -> I -> PI QPN
forall qpn. qpn -> I -> PI qpn
PI (PackagePath -> QPN
qpn PackagePath
pp) I
i)
qpn :: PackagePath -> QPN
qpn :: PackagePath -> QPN
qpn PackagePath
pp = PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg)
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton (Q PackagePath
pp PackageName
pn) Maybe (PI PackagePath)
canon = LinkGroup :: PackageName
-> Maybe (PI PackagePath)
-> Set PackagePath
-> ConflictSet
-> LinkGroup
LinkGroup {
lgPackage :: PackageName
lgPackage = PackageName
pn
, lgCanon :: Maybe (PI PackagePath)
lgCanon = Maybe (PI PackagePath)
canon
, lgMembers :: Set PackagePath
lgMembers = PackagePath -> Set PackagePath
forall a. a -> Set a
S.singleton PackagePath
pp
, lgBlame :: ConflictSet
lgBlame = ConflictSet
CS.empty
}
lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ConflictSet
blame LinkGroup
lg LinkGroup
lg' = do
Maybe (PI PackagePath)
canon <- Maybe (PI PackagePath)
-> Maybe (PI PackagePath)
-> Either Conflict (Maybe (PI PackagePath))
forall a. Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
pick (LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg) (LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg')
LinkGroup -> Either Conflict LinkGroup
forall (m :: * -> *) a. Monad m => a -> m a
return LinkGroup :: PackageName
-> Maybe (PI PackagePath)
-> Set PackagePath
-> ConflictSet
-> LinkGroup
LinkGroup {
lgPackage :: PackageName
lgPackage = LinkGroup -> PackageName
lgPackage LinkGroup
lg
, lgCanon :: Maybe (PI PackagePath)
lgCanon = Maybe (PI PackagePath)
canon
, lgMembers :: Set PackagePath
lgMembers = LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg Set PackagePath -> Set PackagePath -> Set PackagePath
forall a. Ord a => Set a -> Set a -> Set a
`S.union` LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg'
, lgBlame :: ConflictSet
lgBlame = [ConflictSet] -> ConflictSet
CS.unions [ConflictSet
blame, LinkGroup -> ConflictSet
lgBlame LinkGroup
lg, LinkGroup -> ConflictSet
lgBlame LinkGroup
lg']
}
where
pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
pick :: Maybe a -> Maybe a -> Either Conflict (Maybe a)
pick Maybe a
Nothing Maybe a
Nothing = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
pick (Just a
x) Maybe a
Nothing = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
pick Maybe a
Nothing (Just a
y) = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
y
pick (Just a
x) (Just a
y) =
if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
else Conflict -> Either Conflict (Maybe a)
forall a b. a -> Either a b
Left ( [ConflictSet] -> ConflictSet
CS.unions [
ConflictSet
blame
, LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
, LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg'
]
, String
"cannot merge " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg'
)
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg =
[Var QPN] -> ConflictSet
CS.fromList ((PackagePath -> Var QPN) -> [PackagePath] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> Var QPN
aux (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)))
ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgBlame LinkGroup
lg
where
aux :: PackagePath -> Var QPN
aux PackagePath
pp = QPN -> Var QPN
forall qpn. qpn -> Var qpn
P (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg))
allEqual :: Eq a => [a] -> Bool
allEqual :: [a] -> Bool
allEqual [] = Bool
True
allEqual [a
_] = Bool
True
allEqual (a
x:a
y:[a]
ys) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Eq a => [a] -> Bool
allEqual (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)