1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 module Distribution
.Solver
.Modular
.Validate
(validateTree
) where
5 -- Validation of the tree.
7 -- The task here is to make sure all constraints hold. After validation, any
8 -- assignment returned by exploration of the tree should be a complete valid
9 -- assignment, i.e., actually constitute a solution.
11 import Control
.Applicative
12 import Control
.Monad
.Reader
hiding (sequence)
16 import Data
.Traversable
17 import Prelude
hiding (sequence)
19 import Language
.Haskell
.Extension
(Extension
, Language
)
21 import Distribution
.Compiler
(CompilerInfo
(..))
23 import Distribution
.Solver
.Modular
.Assignment
24 import Distribution
.Solver
.Modular
.Dependency
25 import Distribution
.Solver
.Modular
.Flag
26 import Distribution
.Solver
.Modular
.Index
27 import Distribution
.Solver
.Modular
.Package
28 import Distribution
.Solver
.Modular
.Tree
29 import Distribution
.Solver
.Modular
.Version
(VR
)
30 import qualified Distribution
.Solver
.Modular
.WeightedPSQ
as W
32 import Distribution
.Solver
.Types
.ComponentDeps
(Component
)
34 import Distribution
.Solver
.Types
.PackagePath
35 import Distribution
.Solver
.Types
.PkgConfigDb
(PkgConfigDb
, pkgConfigPkgIsPresent
)
37 -- In practice, most constraints are implication constraints (IF we have made
38 -- a number of choices, THEN we also have to ensure that). We call constraints
39 -- that for which the preconditions are fulfilled ACTIVE. We maintain a set
40 -- of currently active constraints that we pass down the node.
42 -- We aim at detecting inconsistent states as early as possible.
44 -- Whenever we make a choice, there are two things that need to happen:
46 -- (1) We must check that the choice is consistent with the currently
47 -- active constraints.
49 -- (2) The choice increases the set of active constraints. For the new
50 -- active constraints, we must check that they are consistent with
53 -- We can actually merge (1) and (2) by saying the the current choice is
54 -- a new active constraint, fixing the choice.
56 -- If a test fails, we have detected an inconsistent state. We can
57 -- disable the current subtree and do not have to traverse it any further.
59 -- We need a good way to represent the current state, i.e., the current
60 -- set of active constraints. Since the main situation where we have to
61 -- search in it is (1), it seems best to store the state by package: for
62 -- every package, we store which versions are still allowed. If for any
63 -- package, we have inconsistent active constraints, we can also stop.
64 -- This is a particular way to read task (2):
66 -- (2, weak) We only check if the new constraints are consistent with
67 -- the choices we've already made, and add them to the active set.
69 -- (2, strong) We check if the new constraints are consistent with the
70 -- choices we've already made, and the constraints we already have.
72 -- It currently seems as if we're implementing the weak variant. However,
73 -- when used together with 'preferEasyGoalChoices', we will find an
74 -- inconsistent state in the very next step.
76 -- What do we do about flags?
78 -- Like for packages, we store the flag choices we have already made.
79 -- Now, regarding (1), we only have to test whether we've decided the
80 -- current flag before. Regarding (2), the interesting bit is in discovering
81 -- the new active constraints. To this end, we look up the constraints for
82 -- the package the flag belongs to, and traverse its flagged dependencies.
83 -- Wherever we find the flag in question, we start recording dependencies
84 -- underneath as new active dependencies. If we encounter other flags, we
85 -- check if we've chosen them already and either proceed or stop.
87 -- | The state needed during validation.
88 data ValidateState
= VS
{
89 supportedExt
:: Extension
-> Bool,
90 supportedLang
:: Language
-> Bool,
91 presentPkgs
:: PkgconfigName
-> VR
-> Bool,
93 saved
:: Map QPN
(FlaggedDeps Component QPN
), -- saved, scoped, dependencies
95 qualifyOptions
:: QualifyOptions
98 newtype Validate a
= Validate
(Reader ValidateState a
)
99 deriving (Functor
, Applicative
, Monad
, MonadReader ValidateState
)
101 runValidate
:: Validate a
-> ValidateState
-> a
102 runValidate
(Validate r
) = runReader r
104 validate
:: Tree d c
-> Validate
(Tree d c
)
107 go
:: TreeF d c
(Validate
(Tree d c
)) -> Validate
(Tree d c
)
109 go
(PChoiceF qpn gr ts
) = PChoice qpn gr
<$> sequence (W
.mapWithKey
(goP qpn
) ts
)
110 go
(FChoiceF qfn gr b m ts
) =
112 -- Flag choices may occur repeatedly (because they can introduce new constraints
113 -- in various places). However, subsequent choices must be consistent. We thereby
114 -- collapse repeated flag choice nodes.
115 PA _ pfa _
<- asks pa
-- obtain current flag-preassignment
116 case M
.lookup qfn pfa
of
117 Just rb
-> -- flag has already been assigned; collapse choice to the correct branch
118 case W
.lookup rb ts
of
119 Just t
-> goF qfn rb t
120 Nothing
-> return $ Fail
(varToConflictSet
(F qfn
)) (MalformedFlagChoice qfn
)
121 Nothing
-> -- flag choice is new, follow both branches
122 FChoice qfn gr b m
<$> sequence (W
.mapWithKey
(goF qfn
) ts
)
123 go
(SChoiceF qsn gr b ts
) =
125 -- Optional stanza choices are very similar to flag choices.
126 PA _ _ psa
<- asks pa
-- obtain current stanza-preassignment
127 case M
.lookup qsn psa
of
128 Just rb
-> -- stanza choice has already been made; collapse choice to the correct branch
129 case W
.lookup rb ts
of
130 Just t
-> goS qsn rb t
131 Nothing
-> return $ Fail
(varToConflictSet
(S qsn
)) (MalformedStanzaChoice qsn
)
132 Nothing
-> -- stanza choice is new, follow both branches
133 SChoice qsn gr b
<$> sequence (W
.mapWithKey
(goS qsn
) ts
)
135 -- We don't need to do anything for goal choices or failure nodes.
136 go
(GoalChoiceF ts
) = GoalChoice
<$> sequence ts
137 go
(DoneF rdm s
) = pure
(Done rdm s
)
138 go
(FailF c fr
) = pure
(Fail c fr
)
140 -- What to do for package nodes ...
141 goP
:: QPN
-> POption
-> Validate
(Tree d c
) -> Validate
(Tree d c
)
142 goP qpn
@(Q _pp pn
) (POption i _
) r
= do
143 PA ppa pfa psa
<- asks pa
-- obtain current preassignment
144 extSupported
<- asks supportedExt
-- obtain the supported extensions
145 langSupported
<- asks supportedLang
-- obtain the supported languages
146 pkgPresent
<- asks presentPkgs
-- obtain the present pkg-config pkgs
147 idx
<- asks
index -- obtain the index
148 svd
<- asks saved
-- obtain saved dependencies
149 qo
<- asks qualifyOptions
150 -- obtain dependencies and index-dictated exclusions introduced by the choice
151 let (PInfo deps _ mfr
) = idx
! pn
! i
152 -- qualify the deps in the current scope
153 let qdeps
= qualifyDeps qo qpn deps
154 -- the new active constraints are given by the instance we have chosen,
155 -- plus the dependency information we have for that instance
156 -- TODO: is the False here right?
157 let newactives
= Dep
False {- not exe -} qpn
(Fixed i
(P qpn
)) : L
.map (resetVar
(P qpn
)) (extractDeps pfa psa qdeps
)
158 -- We now try to extend the partial assignment with the new active constraints.
159 let mnppa
= extend extSupported langSupported pkgPresent
(P qpn
) ppa newactives
160 -- In case we continue, we save the scoped dependencies
161 let nsvd
= M
.insert qpn qdeps svd
163 Just fr
-> -- The index marks this as an invalid choice. We can stop.
164 return (Fail
(varToConflictSet
(P qpn
)) fr
)
166 Left
(c
, d
) -> -- We have an inconsistency. We can stop.
167 return (Fail c
(Conflicting d
))
168 Right nppa
-> -- We have an updated partial assignment for the recursive validation.
169 local
(\ s
-> s
{ pa
= PA nppa pfa psa
, saved
= nsvd
}) r
171 -- What to do for flag nodes ...
172 goF
:: QFN
-> Bool -> Validate
(Tree d c
) -> Validate
(Tree d c
)
173 goF qfn
@(FN
(PI qpn _i
) _f
) b r
= do
174 PA ppa pfa psa
<- asks pa
-- obtain current preassignment
175 extSupported
<- asks supportedExt
-- obtain the supported extensions
176 langSupported
<- asks supportedLang
-- obtain the supported languages
177 pkgPresent
<- asks presentPkgs
-- obtain the present pkg-config pkgs
178 svd
<- asks saved
-- obtain saved dependencies
179 -- Note that there should be saved dependencies for the package in question,
180 -- because while building, we do not choose flags before we see the packages
182 let qdeps
= svd
! qpn
183 -- We take the *saved* dependencies, because these have been qualified in the
186 -- Extend the flag assignment
187 let npfa
= M
.insert qfn b pfa
188 -- We now try to get the new active dependencies we might learn about because
189 -- we have chosen a new flag.
190 let newactives
= extractNewDeps
(F qfn
) b npfa psa qdeps
191 -- As in the package case, we try to extend the partial assignment.
192 case extend extSupported langSupported pkgPresent
(F qfn
) ppa newactives
of
193 Left
(c
, d
) -> return (Fail c
(Conflicting d
)) -- inconsistency found
194 Right nppa
-> local
(\ s
-> s
{ pa
= PA nppa npfa psa
}) r
196 -- What to do for stanza nodes (similar to flag nodes) ...
197 goS
:: QSN
-> Bool -> Validate
(Tree d c
) -> Validate
(Tree d c
)
198 goS qsn
@(SN
(PI qpn _i
) _f
) b r
= do
199 PA ppa pfa psa
<- asks pa
-- obtain current preassignment
200 extSupported
<- asks supportedExt
-- obtain the supported extensions
201 langSupported
<- asks supportedLang
-- obtain the supported languages
202 pkgPresent
<- asks presentPkgs
-- obtain the present pkg-config pkgs
203 svd
<- asks saved
-- obtain saved dependencies
204 -- Note that there should be saved dependencies for the package in question,
205 -- because while building, we do not choose flags before we see the packages
207 let qdeps
= svd
! qpn
208 -- We take the *saved* dependencies, because these have been qualified in the
211 -- Extend the flag assignment
212 let npsa
= M
.insert qsn b psa
213 -- We now try to get the new active dependencies we might learn about because
214 -- we have chosen a new flag.
215 let newactives
= extractNewDeps
(S qsn
) b pfa npsa qdeps
216 -- As in the package case, we try to extend the partial assignment.
217 case extend extSupported langSupported pkgPresent
(S qsn
) ppa newactives
of
218 Left
(c
, d
) -> return (Fail c
(Conflicting d
)) -- inconsistency found
219 Right nppa
-> local
(\ s
-> s
{ pa
= PA nppa pfa npsa
}) r
221 -- | We try to extract as many concrete dependencies from the given flagged
222 -- dependencies as possible. We make use of all the flag knowledge we have
224 extractDeps
:: FAssignment
-> SAssignment
-> FlaggedDeps comp QPN
-> [Dep QPN
]
225 extractDeps fa sa deps
= do
228 Simple sd _
-> return sd
229 Flagged qfn _ td fd
-> case M
.lookup qfn fa
of
231 Just
True -> extractDeps fa sa td
232 Just
False -> extractDeps fa sa fd
233 Stanza qsn td
-> case M
.lookup qsn sa
of
235 Just
True -> extractDeps fa sa td
238 -- | We try to find new dependencies that become available due to the given
239 -- flag or stanza choice. We therefore look for the choice in question, and then call
240 -- 'extractDeps' for everything underneath.
241 extractNewDeps
:: Var QPN
-> Bool -> FAssignment
-> SAssignment
-> FlaggedDeps comp QPN
-> [Dep QPN
]
242 extractNewDeps v b fa sa
= go
244 go
:: FlaggedDeps comp QPN
-> [Dep QPN
] -- Type annotation necessary (polymorphic recursion)
250 | v
== F qfn
' -> L
.map (resetVar v
) $
251 if b
then extractDeps fa sa td
else extractDeps fa sa fd
252 |
otherwise -> case M
.lookup qfn
' fa
of
257 | v
== S qsn
' -> L
.map (resetVar v
) $
258 if b
then extractDeps fa sa td
else []
259 |
otherwise -> case M
.lookup qsn
' sa
of
265 validateTree
:: CompilerInfo
-> Index
-> PkgConfigDb
-> Tree d c
-> Tree d c
266 validateTree cinfo idx pkgConfigDb t
= runValidate
(validate t
) VS
{
267 supportedExt
= maybe (const True) -- if compiler has no list of extensions, we assume everything is supported
268 (\ es
-> let s
= S
.fromList es
in \ x
-> S
.member x s
)
269 (compilerInfoExtensions cinfo
)
270 , supportedLang
= maybe (const True)
271 (flip L
.elem) -- use list lookup because language list is small and no Ord instance
272 (compilerInfoLanguages cinfo
)
273 , presentPkgs
= pkgConfigPkgIsPresent pkgConfigDb
276 , pa
= PA M
.empty M
.empty M
.empty
277 , qualifyOptions
= defaultQualifyOptions idx