{-# 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 = (Reader ValidateState (Tree d c) -> ValidateState -> Tree d c
forall r a. Reader r a -> r -> a
`runReader` ValidateState
initVS) (Reader ValidateState (Tree d c) -> Tree d c)
-> (Tree d c -> Reader ValidateState (Tree d c))
-> Tree d c
-> Tree d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d c -> Reader ValidateState (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go
where
go :: Tree d c -> Validate (Tree d c)
go :: forall d c. Tree d c -> Validate (Tree d c)
go (PChoice QPN
qpn RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Tree d c)
cs) =
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
forall d c.
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
PChoice QPN
qpn RevDepMap
rdm c
gr (WeightedPSQ [Weight] POption (Tree d c) -> Tree d c)
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
-> ReaderT ValidateState Identity (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((POption
-> ReaderT ValidateState Identity (Tree d c)
-> ReaderT ValidateState Identity (Tree d c))
-> WeightedPSQ
[Weight] POption (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (QPN
-> POption
-> ReaderT ValidateState Identity (Tree d c)
-> ReaderT ValidateState Identity (Tree d c)
forall d c.
QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP QPN
qpn) (WeightedPSQ
[Weight] POption (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c)))
-> WeightedPSQ
[Weight] POption (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] POption (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> ReaderT ValidateState Identity (Tree d c))
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ
[Weight] POption (ReaderT ValidateState Identity (Tree d c))
forall a b.
(a -> b)
-> WeightedPSQ [Weight] POption a -> WeightedPSQ [Weight] POption b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] POption (Tree d c)
cs)
go (FChoice FN QPN
qfn RevDepMap
rdm c
gr WeakOrTrivial
t FlagType
m Bool
d WeightedPSQ [Weight] Bool (Tree d c)
cs) =
FN QPN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
FN QPN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
FChoice FN QPN
qfn RevDepMap
rdm c
gr WeakOrTrivial
t FlagType
m Bool
d (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> ReaderT ValidateState Identity (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool
-> ReaderT ValidateState Identity (Tree d c)
-> ReaderT ValidateState Identity (Tree d c))
-> WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (FN QPN
-> Bool
-> ReaderT ValidateState Identity (Tree d c)
-> ReaderT ValidateState Identity (Tree d c)
forall d c.
FN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF FN QPN
qfn) (WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c)))
-> WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> ReaderT ValidateState Identity (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
forall a b.
(a -> b)
-> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
cs)
go (SChoice SN QPN
qsn RevDepMap
rdm c
gr WeakOrTrivial
t WeightedPSQ [Weight] Bool (Tree d c)
cs) =
SN QPN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
SN QPN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
SChoice SN QPN
qsn RevDepMap
rdm c
gr WeakOrTrivial
t (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> ReaderT ValidateState Identity (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool
-> ReaderT ValidateState Identity (Tree d c)
-> ReaderT ValidateState Identity (Tree d c))
-> WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall (f :: * -> *) k v v' w.
Applicative f =>
(k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v')
W.traverseWithKey (SN QPN
-> Bool
-> ReaderT ValidateState Identity (Tree d c)
-> ReaderT ValidateState Identity (Tree d c)
forall d c.
SN QPN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS SN QPN
qsn) (WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c)))
-> WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
-> ReaderT
ValidateState Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall a b. (a -> b) -> a -> b
$ (Tree d c -> ReaderT ValidateState Identity (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ
[Weight] Bool (ReaderT ValidateState Identity (Tree d c))
forall a b.
(a -> b)
-> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
cs)
go (GoalChoice RevDepMap
rdm PSQ (Goal QPN) (Tree d c)
cs) = RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
forall d c. RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
GoalChoice RevDepMap
rdm (PSQ (Goal QPN) (Tree d c) -> Tree d c)
-> ReaderT ValidateState Identity (PSQ (Goal QPN) (Tree d c))
-> ReaderT ValidateState Identity (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree d c -> ReaderT ValidateState Identity (Tree d c))
-> PSQ (Goal QPN) (Tree d c)
-> ReaderT ValidateState Identity (PSQ (Goal QPN) (Tree d c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PSQ (Goal QPN) a -> f (PSQ (Goal QPN) b)
T.traverse Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall d c. Tree d c -> Validate (Tree d c)
go PSQ (Goal QPN) (Tree d c)
cs
go (Done RevDepMap
revDepMap d
s) = Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall a. a -> ReaderT ValidateState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> ReaderT ValidateState Identity (Tree d c))
-> Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall a b. (a -> b) -> a -> b
$ RevDepMap -> d -> Tree d c
forall d c. RevDepMap -> d -> Tree d c
Done RevDepMap
revDepMap d
s
go (Fail ConflictSet
conflictSet FailReason
failReason) = Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall a. a -> ReaderT ValidateState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> ReaderT ValidateState Identity (Tree d c))
-> Tree d c -> ReaderT ValidateState Identity (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
conflictSet FailReason
failReason
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 <- 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 a. a -> ReaderT ValidateState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall a.
(ValidateState -> ValidateState)
-> ReaderT ValidateState Identity a
-> ReaderT ValidateState Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ValidateState -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs' { vsSaved = newSaved }) Validate (Tree d c)
r
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 <- ReaderT ValidateState Identity ValidateState
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) -> Tree d c -> Validate (Tree d c)
forall a. a -> ReaderT ValidateState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall a.
(ValidateState -> ValidateState)
-> ReaderT ValidateState Identity a
-> ReaderT ValidateState Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ValidateState -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs') Validate (Tree d c)
r
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 <- ReaderT ValidateState Identity ValidateState
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) -> Tree d c -> Validate (Tree d c)
forall a. a -> ReaderT ValidateState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> Validate (Tree d c))
-> Tree d c -> Validate (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
cs (String -> FailReason
DependenciesNotLinked String
err)
Right ValidateState
vs' -> (ValidateState -> ValidateState)
-> Validate (Tree d c) -> Validate (Tree d c)
forall a.
(ValidateState -> ValidateState)
-> ReaderT ValidateState Identity a
-> ReaderT ValidateState Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ValidateState -> ValidateState -> ValidateState
forall a b. a -> b -> a
const ValidateState
vs') Validate (Tree d c)
r
initVS :: ValidateState
initVS :: ValidateState
initVS = VS {
vsIndex :: Index
vsIndex = Index
index
, vsLinks :: Map QPN LinkGroup
vsLinks = Map QPN LinkGroup
forall k a. Map k a
M.empty
, vsFlags :: FAssignment
vsFlags = FAssignment
forall k a. Map k a
M.empty
, vsStanzas :: SAssignment
vsStanzas = SAssignment
forall k a. Map k a
M.empty
, vsQualifyOptions :: QualifyOptions
vsQualifyOptions = Index -> QualifyOptions
defaultQualifyOptions Index
index
, vsSaved :: Map QPN (FlaggedDeps QPN)
vsSaved = Map QPN (FlaggedDeps QPN)
forall k a. Map k a
M.empty
}
type Conflict = (ConflictSet, String)
newtype UpdateState a = UpdateState {
forall a. UpdateState a -> StateT ValidateState (Either Conflict) a
unUpdateState :: StateT ValidateState (Either Conflict) a
}
deriving ((forall a b. (a -> b) -> UpdateState a -> UpdateState b)
-> (forall a b. a -> UpdateState b -> UpdateState a)
-> Functor UpdateState
forall a b. a -> UpdateState b -> UpdateState a
forall a b. (a -> b) -> UpdateState a -> UpdateState b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
fmap :: forall a b. (a -> b) -> UpdateState a -> UpdateState b
$c<$ :: forall a b. a -> UpdateState b -> UpdateState a
<$ :: forall a b. a -> UpdateState b -> UpdateState a
Functor, Functor UpdateState
Functor UpdateState =>
(forall a. a -> UpdateState a)
-> (forall a b.
UpdateState (a -> b) -> UpdateState a -> UpdateState b)
-> (forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState b)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState a)
-> Applicative UpdateState
forall a. a -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState b
forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> UpdateState a
pure :: forall a. a -> UpdateState a
$c<*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
<*> :: forall a b. UpdateState (a -> b) -> UpdateState a -> UpdateState b
$cliftA2 :: forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
liftA2 :: forall a b c.
(a -> b -> c) -> UpdateState a -> UpdateState b -> UpdateState c
$c*> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
*> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
$c<* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
<* :: forall a b. UpdateState a -> UpdateState b -> UpdateState a
Applicative, Applicative UpdateState
Applicative UpdateState =>
(forall a b.
UpdateState a -> (a -> UpdateState b) -> UpdateState b)
-> (forall a b. UpdateState a -> UpdateState b -> UpdateState b)
-> (forall a. a -> UpdateState a)
-> Monad UpdateState
forall a. a -> UpdateState a
forall a b. UpdateState a -> UpdateState b -> UpdateState b
forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
>>= :: forall a b. UpdateState a -> (a -> UpdateState b) -> UpdateState b
$c>> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
>> :: forall a b. UpdateState a -> UpdateState b -> UpdateState b
$creturn :: forall a. a -> UpdateState a
return :: forall a. a -> UpdateState a
Monad)
instance MonadState ValidateState UpdateState where
get :: UpdateState ValidateState
get = StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState)
-> StateT ValidateState (Either Conflict) ValidateState
-> UpdateState ValidateState
forall a b. (a -> b) -> a -> b
$ StateT ValidateState (Either Conflict) ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
put :: ValidateState -> UpdateState ()
put ValidateState
st = StateT ValidateState (Either Conflict) () -> UpdateState ()
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) () -> UpdateState ())
-> StateT ValidateState (Either Conflict) () -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ do
Bool
-> StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ()
forall a. Bool -> a -> a
expensiveAssert (Map QPN LinkGroup -> Bool
lgInvariant (Map QPN LinkGroup -> Bool) -> Map QPN LinkGroup -> Bool
forall a b. (a -> b) -> a -> b
$ ValidateState -> Map QPN LinkGroup
vsLinks ValidateState
st) (StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ())
-> StateT ValidateState (Either Conflict) ()
-> StateT ValidateState (Either Conflict) ()
forall a b. (a -> b) -> a -> b
$ () -> StateT ValidateState (Either Conflict) ()
forall a. a -> StateT ValidateState (Either Conflict) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ValidateState -> StateT ValidateState (Either Conflict) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ValidateState
st
lift' :: Either Conflict a -> UpdateState a
lift' :: forall a. Either Conflict a -> UpdateState a
lift' = StateT ValidateState (Either Conflict) a -> UpdateState a
forall a. StateT ValidateState (Either Conflict) a -> UpdateState a
UpdateState (StateT ValidateState (Either Conflict) a -> UpdateState a)
-> (Either Conflict a -> StateT ValidateState (Either Conflict) a)
-> Either Conflict a
-> UpdateState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Conflict a -> StateT ValidateState (Either Conflict) a
forall (m :: * -> *) a. Monad m => m a -> StateT ValidateState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
conflict :: Conflict -> UpdateState a
conflict :: forall a. Conflict -> UpdateState a
conflict = Either Conflict a -> UpdateState a
forall a. Either Conflict a -> UpdateState a
lift' (Either Conflict a -> UpdateState a)
-> (Conflict -> Either Conflict a) -> Conflict -> UpdateState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conflict -> Either Conflict a
forall a b. a -> Either a b
Left
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState = StateT ValidateState (Either Conflict) ()
-> ValidateState -> Either Conflict ValidateState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT ValidateState (Either Conflict) ()
-> ValidateState -> Either Conflict ValidateState)
-> (UpdateState () -> StateT ValidateState (Either Conflict) ())
-> UpdateState ()
-> ValidateState
-> Either Conflict ValidateState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateState () -> StateT ValidateState (Either Conflict) ()
forall a. UpdateState a -> StateT ValidateState (Either Conflict) a
unUpdateState
pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
pickPOption QPN
qpn (POption I
i Maybe PackagePath
Nothing) FlaggedDeps QPN
_deps = QPN -> I -> UpdateState ()
pickConcrete QPN
qpn I
i
pickPOption QPN
qpn (POption I
i (Just PackagePath
pp')) FlaggedDeps QPN
deps = QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
pickLink QPN
qpn I
i PackagePath
pp' FlaggedDeps QPN
deps
pickConcrete :: QPN -> I -> UpdateState ()
pickConcrete :: QPN -> I -> UpdateState ()
pickConcrete qpn :: QPN
qpn@(Q PackagePath
pp PackageName
_) I
i = do
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 a. a -> UpdateState a
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 = Just (PI pp 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 FN QPN
fn FInfo
_ FlaggedDeps QPN
t FlaggedDeps QPN
f, ~(Flagged FN QPN
_ FInfo
_ FlaggedDeps QPN
t' FlaggedDeps QPN
f')) -> do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
case FN QPN -> FAssignment -> Maybe Bool
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 -> () -> UpdateState ()
forall a. a -> UpdateState a
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 <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
case SN QPN -> SAssignment -> Maybe Bool
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 -> () -> UpdateState ()
forall a. a -> UpdateState a
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 a. a -> UpdateState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Ext Extension
_)) Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall a. a -> UpdateState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Lang Language
_)) Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall a. a -> UpdateState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Simple (LDep DependencyReason QPN
_ (Pkg PkgconfigName
_ PkgconfigVersionRange
_)) Component
_, FlaggedDep QPN
_) -> () -> UpdateState ()
forall a. a -> UpdateState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify FlaggedDeps QPN
deps = do
ValidateState
vs <- UpdateState ValidateState
forall s (m :: * -> *). MonadState s m => m s
get
FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
forall a. a -> UpdateState a
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 :: FN QPN -> Bool -> UpdateState ()
pickFlag FN QPN
qfn Bool
b = do
(ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsFlags = M.insert qfn b (vsFlags vs) }
FN QPN -> UpdateState ()
verifyFlag FN QPN
qfn
Var QPN -> Bool -> UpdateState ()
linkNewDeps (FN QPN -> Var QPN
forall qpn. FN qpn -> Var qpn
F FN QPN
qfn) Bool
b
pickStanza :: QSN -> Bool -> UpdateState ()
pickStanza :: SN QPN -> Bool -> UpdateState ()
pickStanza SN QPN
qsn Bool
b = do
(ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs { vsStanzas = M.insert qsn b (vsStanzas vs) }
SN QPN -> UpdateState ()
verifyStanza SN QPN
qsn
Var QPN -> Bool -> UpdateState ()
linkNewDeps (SN QPN -> Var QPN
forall qpn. SN qpn -> Var qpn
S SN QPN
qsn) Bool
b
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 FN QPN
qfn FInfo
_ FlaggedDeps QPN
t FlaggedDeps QPN
f) =
case (FN QPN -> Var QPN
forall qpn. FN qpn -> Var qpn
F FN QPN
qfn Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== Var QPN
var, FN QPN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FN QPN
qfn (ValidateState -> FAssignment
vsFlags ValidateState
vs)) of
(Bool
True, Maybe Bool
_) -> if Bool
b then FlaggedDeps QPN
t else FlaggedDeps QPN
f
(Bool
_, Maybe Bool
Nothing) -> []
(Bool
_, Just Bool
b') -> ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs (if Bool
b' then FlaggedDeps QPN
t else FlaggedDeps QPN
f)
findNewDeps' ValidateState
vs (Stanza SN QPN
qsn FlaggedDeps QPN
t) =
case (SN QPN -> Var QPN
forall qpn. SN qpn -> Var qpn
S SN QPN
qsn Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
== Var QPN
var, SN QPN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SN QPN
qsn (ValidateState -> SAssignment
vsStanzas ValidateState
vs)) of
(Bool
True, Maybe Bool
_) -> if Bool
b then FlaggedDeps QPN
t else []
(Bool
_, Maybe Bool
Nothing) -> []
(Bool
_, Just Bool
b') -> ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
findNewDeps ValidateState
vs (if Bool
b' then FlaggedDeps QPN
t else [])
updateLinkGroup :: LinkGroup -> UpdateState ()
updateLinkGroup :: LinkGroup -> UpdateState ()
updateLinkGroup LinkGroup
lg = do
LinkGroup -> UpdateState ()
verifyLinkGroup LinkGroup
lg
(ValidateState -> ValidateState) -> UpdateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ValidateState -> ValidateState) -> UpdateState ())
-> (ValidateState -> ValidateState) -> UpdateState ()
forall a b. (a -> b) -> a -> b
$ \ValidateState
vs -> ValidateState
vs {
vsLinks = M.fromList (map aux (S.toList (lgMembers lg)))
`M.union` vsLinks vs
}
where
aux :: PackagePath -> (QPN, LinkGroup)
aux PackagePath
pp = (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg), LinkGroup
lg)
verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup LinkGroup
lg =
case LinkGroup -> Maybe I
lgInstance LinkGroup
lg of
Maybe I
Nothing ->
() -> UpdateState ()
forall a. a -> UpdateState a
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 :: FN QPN -> 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 :: SN QPN -> 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 :: [FN QPN]
flags = (PackagePath -> FN QPN) -> [PackagePath] -> [FN QPN]
forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> QPN -> Flag -> FN QPN
forall qpn. qpn -> Flag -> FN qpn
FN (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) Flag
fn) (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
vals :: [Maybe Bool]
vals = (FN QPN -> Maybe Bool) -> [FN QPN] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (FN QPN -> FAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> FAssignment
vsFlags ValidateState
vs) [FN QPN]
flags
if [Bool] -> Bool
forall a. Eq a => [a] -> Bool
allEqual ([Maybe Bool] -> [Bool]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals)
then () -> UpdateState ()
forall a. a -> UpdateState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList ((FN QPN -> Var QPN) -> [FN QPN] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map FN QPN -> Var QPN
forall qpn. FN qpn -> Var qpn
F [FN QPN]
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 :: [SN QPN]
stanzas = (PackagePath -> SN QPN) -> [PackagePath] -> [SN QPN]
forall a b. (a -> b) -> [a] -> [b]
map (\PackagePath
pp' -> QPN -> OptionalStanza -> SN QPN
forall qpn. qpn -> OptionalStanza -> SN qpn
SN (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) OptionalStanza
sn) (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))
vals :: [Maybe Bool]
vals = (SN QPN -> Maybe Bool) -> [SN QPN] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (SN QPN -> SAssignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValidateState -> SAssignment
vsStanzas ValidateState
vs) [SN QPN]
stanzas
if [Bool] -> Bool
forall a. Eq a => [a] -> Bool
allEqual ([Maybe Bool] -> [Bool]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Bool]
vals)
then () -> UpdateState ()
forall a. a -> UpdateState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Conflict -> UpdateState ()
forall a. Conflict -> UpdateState a
conflict ( [Var QPN] -> ConflictSet
CS.fromList ((SN QPN -> Var QPN) -> [SN QPN] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map SN QPN -> Var QPN
forall qpn. SN qpn -> Var qpn
S [SN QPN]
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
$cshowsPrec :: Int -> LinkGroup -> String -> String
showsPrec :: Int -> LinkGroup -> String -> String
$cshow :: LinkGroup -> String
show :: LinkGroup -> String
$cshowList :: [LinkGroup] -> String -> String
showList :: [LinkGroup] -> String -> String
Show, LinkGroup -> LinkGroup -> Bool
(LinkGroup -> LinkGroup -> Bool)
-> (LinkGroup -> LinkGroup -> Bool) -> Eq LinkGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LinkGroup -> LinkGroup -> Bool
== :: LinkGroup -> LinkGroup -> Bool
$c/= :: LinkGroup -> LinkGroup -> Bool
/= :: LinkGroup -> LinkGroup -> Bool
Eq)
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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PI PackagePath
_ I
i) -> I
i) (Maybe (PI PackagePath) -> Maybe I)
-> (LinkGroup -> Maybe (PI PackagePath)) -> LinkGroup -> Maybe I
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkGroup -> Maybe (PI PackagePath)
lgCanon
showLinkGroup :: LinkGroup -> String
showLinkGroup :: LinkGroup -> String
showLinkGroup LinkGroup
lg =
String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((PackagePath -> String) -> [PackagePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> String
showMember (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg))) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
where
showMember :: PackagePath -> String
showMember :: PackagePath -> String
showMember PackagePath
pp = case LinkGroup -> Maybe (PI PackagePath)
lgCanon LinkGroup
lg of
Just (PI PackagePath
pp' I
_i) | PackagePath
pp PackagePath -> PackagePath -> Bool
forall a. Eq a => a -> a -> Bool
== PackagePath
pp' -> String
"*"
Maybe (PI PackagePath)
_otherwise -> String
""
String -> String -> String
forall a. [a] -> [a] -> [a]
++ case LinkGroup -> Maybe I
lgInstance LinkGroup
lg of
Maybe I
Nothing -> QPN -> String
showQPN (PackagePath -> QPN
qpn PackagePath
pp)
Just I
i -> PI QPN -> String
showPI (QPN -> I -> PI QPN
forall qpn. qpn -> I -> PI qpn
PI (PackagePath -> QPN
qpn PackagePath
pp) I
i)
qpn :: PackagePath -> QPN
qpn :: PackagePath -> QPN
qpn PackagePath
pp = PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg)
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton (Q PackagePath
pp PackageName
pn) Maybe (PI PackagePath)
canon = LinkGroup {
lgPackage :: PackageName
lgPackage = PackageName
pn
, lgCanon :: Maybe (PI PackagePath)
lgCanon = Maybe (PI PackagePath)
canon
, lgMembers :: Set PackagePath
lgMembers = PackagePath -> Set PackagePath
forall a. a -> Set a
S.singleton PackagePath
pp
, lgBlame :: ConflictSet
lgBlame = ConflictSet
CS.empty
}
lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge ConflictSet
blame LinkGroup
lg LinkGroup
lg' = do
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 a. a -> Either Conflict a
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 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 :: forall a. Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
pick Maybe a
Nothing Maybe a
Nothing = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
pick (Just a
x) Maybe a
Nothing = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
pick Maybe a
Nothing (Just a
y) = Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
y
pick (Just a
x) (Just a
y) =
if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then Maybe a -> Either Conflict (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Conflict (Maybe a))
-> Maybe a -> Either Conflict (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
else Conflict -> Either Conflict (Maybe a)
forall a b. a -> Either a b
Left ( [ConflictSet] -> ConflictSet
CS.unions [
ConflictSet
blame
, LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg
, LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg'
]
, String
"cannot merge " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LinkGroup -> String
showLinkGroup LinkGroup
lg'
)
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet LinkGroup
lg =
[Var QPN] -> ConflictSet
CS.fromList ((PackagePath -> Var QPN) -> [PackagePath] -> [Var QPN]
forall a b. (a -> b) -> [a] -> [b]
map PackagePath -> Var QPN
aux (Set PackagePath -> [PackagePath]
forall a. Set a -> [a]
S.toList (LinkGroup -> Set PackagePath
lgMembers LinkGroup
lg)))
ConflictSet -> ConflictSet -> ConflictSet
`CS.union` LinkGroup -> ConflictSet
lgBlame LinkGroup
lg
where
aux :: PackagePath -> Var QPN
aux PackagePath
pp = QPN -> Var QPN
forall qpn. qpn -> Var qpn
P (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp (LinkGroup -> PackageName
lgPackage LinkGroup
lg))
allEqual :: Eq a => [a] -> Bool
allEqual :: forall a. Eq a => [a] -> Bool
allEqual [] = Bool
True
allEqual [a
_] = Bool
True
allEqual (a
x:a
y:[a]
ys) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Eq a => [a] -> Bool
allEqual (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)