Tree.hs 7.01 KB
Newer Older
1
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
2
3
4
5
6
7
8
9
module Distribution.Client.Dependency.Modular.Tree
    ( FailReason(..)
    , POption(..)
    , Tree(..)
    , TreeF(..)
    , ana
    , cata
    , choices
Andres Löh's avatar
Andres Löh committed
10
    , dchoices
11
12
13
14
    , inn
    , innM
    , para
    , trav
Andres Löh's avatar
Andres Löh committed
15
    , zeroOrOneChoices
16
    ) where
17

Edsko de Vries's avatar
Edsko de Vries committed
18
import Control.Monad hiding (mapM, sequence)
19
20
import Data.Foldable
import Data.Traversable
Edsko de Vries's avatar
Edsko de Vries committed
21
import Prelude hiding (foldr, mapM, sequence)
22
23
24
25

import Distribution.Client.Dependency.Modular.Dependency
import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
26
27
import Distribution.Client.Dependency.Modular.PSQ (PSQ)
import qualified Distribution.Client.Dependency.Modular.PSQ as P
28
import Distribution.Client.Dependency.Modular.Version
29
import Distribution.Client.Dependency.Types ( ConstraintSource(..) )
30
31
32

-- | Type of the search tree. Inlining the choice nodes for now.
data Tree a =
33
34
35
36
    PChoice     QPN a           (PSQ POption       (Tree a))
  | FChoice     QFN a Bool Bool (PSQ Bool          (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual
  | SChoice     QSN a Bool      (PSQ Bool          (Tree a)) -- Bool indicates whether it's trivial
  | GoalChoice                  (PSQ (OpenGoal ()) (Tree a)) -- PSQ should never be empty
37
  | Done        RevDepMap
38
  | Fail        (ConflictSet QPN) FailReason
39
  deriving (Eq, Show, Functor)
Andres Löh's avatar
Andres Löh committed
40
41
42
  -- Above, a choice is called trivial if it clearly does not matter. The
  -- special case of triviality we actually consider is if there are no new
  -- dependencies introduced by this node.
Andres Löh's avatar
Andres Löh committed
43
44
45
46
47
  --
  -- A (flag) choice is called weak if we do want to defer it. This is the
  -- case for flags that should be implied by what's currently installed on
  -- the system, as opposed to flags that are used to explicitly enable or
  -- disable some functionality.
48

Edsko de Vries's avatar
Edsko de Vries committed
49
50
51
52
53
54
55
56
57
58
59
-- | A package option is a package instance with an optional linking annotation
--
-- The modular solver has a number of package goals to solve for, and can only
-- pick a single package version for a single goal. In order to allow to
-- install multiple versions of the same package as part of a single solution
-- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both
-- be qualified goals for @P@, allowing to pick a difference version of package
-- @P@ for @0.P@ and @1.P@.
--
-- Linking is an essential part of this story. In addition to picking a specific
-- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or
Edward Z. Yang's avatar
Edward Z. Yang committed
60
-- vice versa). It means that @1.P@ and @0.P@ really must be the very same package
Edsko de Vries's avatar
Edsko de Vries committed
61
62
63
64
-- (and hence must have the same build time configuration, and their
-- dependencies must also be the exact same).
--
-- See <http://www.well-typed.com/blog/2015/03/qualified-goals/> for details.
Edsko de Vries's avatar
Edsko de Vries committed
65
66
67
data POption = POption I (Maybe PP)
  deriving (Eq, Show)

68
data FailReason = InconsistentInitialConstraints
Andres Löh's avatar
Andres Löh committed
69
                | Conflicting [Dep QPN]
70
71
                | CannotInstall
                | CannotReinstall
72
73
                | Shadowed
                | Broken
74
75
76
77
                | GlobalConstraintVersion VR ConstraintSource
                | GlobalConstraintInstalled ConstraintSource
                | GlobalConstraintSource ConstraintSource
                | GlobalConstraintFlag ConstraintSource
78
                | ManualFlag
79
                | BuildFailureNotInIndex PN
Andres Löh's avatar
Andres Löh committed
80
                | MalformedFlagChoice QFN
Andres Löh's avatar
Andres Löh committed
81
                | MalformedStanzaChoice QSN
82
                | EmptyGoalChoice
Andres Löh's avatar
Andres Löh committed
83
                | Backjump
84
                | MultipleInstances
Edsko de Vries's avatar
Edsko de Vries committed
85
                | DependenciesNotLinked String
86
                | CyclicDependencies
87
88
89
90
  deriving (Eq, Show)

-- | Functor for the tree type.
data TreeF a b =
91
92
93
94
    PChoiceF    QPN a           (PSQ POption       b)
  | FChoiceF    QFN a Bool Bool (PSQ Bool          b)
  | SChoiceF    QSN a Bool      (PSQ Bool          b)
  | GoalChoiceF                 (PSQ (OpenGoal ()) b)
95
  | DoneF       RevDepMap
96
  | FailF       (ConflictSet QPN) FailReason
97
  deriving (Functor, Foldable, Traversable)
98
99

out :: Tree a -> TreeF a (Tree a)
100
101
102
103
104
105
out (PChoice    p i     ts) = PChoiceF    p i     ts
out (FChoice    p i b m ts) = FChoiceF    p i b m ts
out (SChoice    p i b   ts) = SChoiceF    p i b   ts
out (GoalChoice         ts) = GoalChoiceF         ts
out (Done       x         ) = DoneF       x
out (Fail       c x       ) = FailF       c x
106

107
inn :: TreeF a (Tree a) -> Tree a
108
109
110
111
112
113
inn (PChoiceF    p i     ts) = PChoice    p i     ts
inn (FChoiceF    p i b m ts) = FChoice    p i b m ts
inn (SChoiceF    p i b   ts) = SChoice    p i b   ts
inn (GoalChoiceF         ts) = GoalChoice         ts
inn (DoneF       x         ) = Done       x
inn (FailF       c x       ) = Fail       c x
114

Edsko de Vries's avatar
Edsko de Vries committed
115
116
117
118
119
120
121
122
innM :: Monad m => TreeF a (m (Tree a)) -> m (Tree a)
innM (PChoiceF    p i     ts) = liftM (PChoice    p i    ) (sequence ts)
innM (FChoiceF    p i b m ts) = liftM (FChoice    p i b m) (sequence ts)
innM (SChoiceF    p i b   ts) = liftM (SChoice    p i b  ) (sequence ts)
innM (GoalChoiceF         ts) = liftM (GoalChoice        ) (sequence ts)
innM (DoneF       x         ) = return $ Done     x
innM (FailF       c x       ) = return $ Fail     c x

123
124
-- | Determines whether a tree is active, i.e., isn't a failure node.
active :: Tree a -> Bool
Andres Löh's avatar
Andres Löh committed
125
126
active (Fail _ _) = False
active _          = True
127
128
129
130

-- | Determines how many active choices are available in a node. Note that we
-- count goal choices as having one choice, always.
choices :: Tree a -> Int
131
132
133
134
135
136
choices (PChoice    _ _     ts) = P.length (P.filter active ts)
choices (FChoice    _ _ _ _ ts) = P.length (P.filter active ts)
choices (SChoice    _ _ _   ts) = P.length (P.filter active ts)
choices (GoalChoice         _ ) = 1
choices (Done       _         ) = 1
choices (Fail       _ _       ) = 0
137

Andres Löh's avatar
Andres Löh committed
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
-- | Variant of 'choices' that only approximates the number of choices.
dchoices :: Tree a -> P.Degree
dchoices (PChoice    _ _     ts) = P.degree (P.filter active ts)
dchoices (FChoice    _ _ _ _ ts) = P.degree (P.filter active ts)
dchoices (SChoice    _ _ _   ts) = P.degree (P.filter active ts)
dchoices (GoalChoice         _ ) = P.ZeroOrOne
dchoices (Done       _         ) = P.ZeroOrOne
dchoices (Fail       _ _       ) = P.ZeroOrOne

-- | Variant of 'choices' that only approximates the number of choices.
zeroOrOneChoices :: Tree a -> Bool
zeroOrOneChoices (PChoice    _ _     ts) = P.isZeroOrOne (P.filter active ts)
zeroOrOneChoices (FChoice    _ _ _ _ ts) = P.isZeroOrOne (P.filter active ts)
zeroOrOneChoices (SChoice    _ _ _   ts) = P.isZeroOrOne (P.filter active ts)
zeroOrOneChoices (GoalChoice         _ ) = True
zeroOrOneChoices (Done       _         ) = True
zeroOrOneChoices (Fail       _ _       ) = True
155
156
157

-- | Catamorphism on trees.
cata :: (TreeF a b -> b) -> Tree a -> b
158
159
cata phi x = (phi . fmap (cata phi) . out) x

160
trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b
161
trav psi x = cata (inn . psi) x
162
163
164
165
166
167
168
169

-- | Paramorphism on trees.
para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b
para phi = phi . fmap (\ x -> (para phi x, x)) . out

-- | Anamorphism on trees.
ana :: (b -> TreeF a b) -> b -> Tree a
ana psi = inn . fmap (ana psi) . psi