never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2 module Distribution.Client.Types.AllowNewer (
3 AllowNewer (..),
4 AllowOlder (..),
5 RelaxDeps (..),
6 mkRelaxDepSome,
7 RelaxDepMod (..),
8 RelaxDepScope (..),
9 RelaxDepSubject (..),
10 RelaxedDep (..),
11 isRelaxDeps,
12 ) where
13
14 import Distribution.Client.Compat.Prelude
15 import Prelude ()
16
17 import Distribution.Parsec (parsecLeadingCommaNonEmpty)
18 import Distribution.Types.PackageId (PackageId, PackageIdentifier (..))
19 import Distribution.Types.PackageName (PackageName, mkPackageName)
20 import Distribution.Types.Version (nullVersion)
21
22 import qualified Distribution.Compat.CharParsing as P
23 import qualified Text.PrettyPrint as Disp
24
25 -- $setup
26 -- >>> import Distribution.Parsec
27
28 -- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,
29 -- it may make sense to move these definitions to the Solver.Types
30 -- module
31
32 -- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)
33 newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }
34 deriving (Eq, Read, Show, Generic)
35
36 -- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)
37 newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }
38 deriving (Eq, Read, Show, Generic)
39
40 -- | Generic data type for policy when relaxing bounds in dependencies.
41 -- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending
42 -- on whether or not you are relaxing an lower or upper bound
43 -- (respectively).
44 data RelaxDeps =
45
46 -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.
47 --
48 -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all
49 -- dependencies, never choose versions newer (resp. older) than allowed.
50 RelaxDepsSome [RelaxedDep]
51
52 -- | Ignore upper (resp. lower) bounds in dependencies on all packages.
53 --
54 -- __Note__: This is should be semantically equivalent to
55 --
56 -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
57 --
58 -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')
59 | RelaxDepsAll
60 deriving (Eq, Read, Show, Generic)
61
62 -- | Dependencies can be relaxed either for all packages in the install plan, or
63 -- only for some packages.
64 data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject
65 deriving (Eq, Read, Show, Generic)
66
67 -- | Specify the scope of a relaxation, i.e. limit which depending
68 -- packages are allowed to have their version constraints relaxed.
69 data RelaxDepScope = RelaxDepScopeAll
70 -- ^ Apply relaxation in any package
71 | RelaxDepScopePackage !PackageName
72 -- ^ Apply relaxation to in all versions of a package
73 | RelaxDepScopePackageId !PackageId
74 -- ^ Apply relaxation to a specific version of a package only
75 deriving (Eq, Read, Show, Generic)
76
77 -- | Modifier for dependency relaxation
78 data RelaxDepMod = RelaxDepModNone -- ^ Default semantics
79 | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints
80 deriving (Eq, Read, Show, Generic)
81
82 -- | Express whether to relax bounds /on/ @all@ packages, or a single package
83 data RelaxDepSubject = RelaxDepSubjectAll
84 | RelaxDepSubjectPkg !PackageName
85 deriving (Eq, Ord, Read, Show, Generic)
86
87 instance Pretty RelaxedDep where
88 pretty (RelaxedDep scope rdmod subj) = case scope of
89 RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep
90 RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
91 RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
92 where
93 modDep = case rdmod of
94 RelaxDepModNone -> pretty subj
95 RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj
96
97 instance Parsec RelaxedDep where
98 parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)
99
100 -- continuation after *
101 relaxedDepStarP :: CabalParsing m => m RelaxedDep
102 relaxedDepStarP =
103 RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
104 <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
105
106 -- continuation after package identifier
107 relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep
108 relaxedDepPkgidP pid@(PackageIdentifier pn v)
109 | pn == mkPackageName "all"
110 , v == nullVersion
111 = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
112 <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
113
114 | v == nullVersion
115 = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec
116 <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))
117
118 | otherwise
119 = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec
120
121 modP :: P.CharParsing m => m RelaxDepMod
122 modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone
123
124 instance Pretty RelaxDepSubject where
125 pretty RelaxDepSubjectAll = Disp.text "*"
126 pretty (RelaxDepSubjectPkg pn) = pretty pn
127
128 instance Parsec RelaxDepSubject where
129 parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn
130 where
131 pkgn = do
132 pn <- parsec
133 pure $ if pn == mkPackageName "all"
134 then RelaxDepSubjectAll
135 else RelaxDepSubjectPkg pn
136
137 instance Pretty RelaxDeps where
138 pretty rd | not (isRelaxDeps rd) = Disp.text "none"
139 pretty (RelaxDepsSome pkgs) = Disp.fsep .
140 Disp.punctuate Disp.comma .
141 map pretty $ pkgs
142 pretty RelaxDepsAll = Disp.text "all"
143
144 -- |
145 --
146 -- >>> simpleParsec "all" :: Maybe RelaxDeps
147 -- Just RelaxDepsAll
148 --
149 -- >>> simpleParsec "none" :: Maybe RelaxDeps
150 -- Just (RelaxDepsSome [])
151 --
152 -- >>> simpleParsec "*, *" :: Maybe RelaxDeps
153 -- Just RelaxDepsAll
154 --
155 -- >>> simpleParsec "*:*" :: Maybe RelaxDeps
156 -- Just RelaxDepsAll
157 --
158 -- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps
159 -- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))])
160 --
161 -- This is not a glitch, even it looks like:
162 --
163 -- >>> simpleParsec ", all" :: Maybe RelaxDeps
164 -- Just RelaxDepsAll
165 --
166 -- >>> simpleParsec "" :: Maybe RelaxDeps
167 -- Nothing
168 --
169 instance Parsec RelaxDeps where
170 parsec = do
171 xs <- parsecLeadingCommaNonEmpty parsec
172 pure $ case toList xs of
173 [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
174 -> RelaxDepsAll
175 [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]
176 | pn == mkPackageName "none"
177 -> mempty
178 xs' -> mkRelaxDepSome xs'
179
180 instance Binary RelaxDeps
181 instance Binary RelaxDepMod
182 instance Binary RelaxDepScope
183 instance Binary RelaxDepSubject
184 instance Binary RelaxedDep
185 instance Binary AllowNewer
186 instance Binary AllowOlder
187
188 instance Structured RelaxDeps
189 instance Structured RelaxDepMod
190 instance Structured RelaxDepScope
191 instance Structured RelaxDepSubject
192 instance Structured RelaxedDep
193 instance Structured AllowNewer
194 instance Structured AllowOlder
195
196 -- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations
197 --
198 -- Equivalent to @isRelaxDeps = (/= 'mempty')@
199 isRelaxDeps :: RelaxDeps -> Bool
200 isRelaxDeps (RelaxDepsSome []) = False
201 isRelaxDeps (RelaxDepsSome (_:_)) = True
202 isRelaxDeps RelaxDepsAll = True
203
204 -- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.
205 mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
206 mkRelaxDepSome xs
207 | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs
208 = RelaxDepsAll
209
210 | otherwise
211 = RelaxDepsSome xs
212
213 -- | 'RelaxDepsAll' is the /absorbing element/
214 instance Semigroup RelaxDeps where
215 -- identity element
216 RelaxDepsSome [] <> r = r
217 l@(RelaxDepsSome _) <> RelaxDepsSome [] = l
218 -- absorbing element
219 l@RelaxDepsAll <> _ = l
220 (RelaxDepsSome _) <> r@RelaxDepsAll = r
221 -- combining non-{identity,absorbing} elements
222 (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b)
223
224 -- | @'RelaxDepsSome' []@ is the /identity element/
225 instance Monoid RelaxDeps where
226 mempty = RelaxDepsSome []
227 mappend = (<>)
228
229 instance Semigroup AllowNewer where
230 AllowNewer x <> AllowNewer y = AllowNewer (x <> y)
231
232 instance Semigroup AllowOlder where
233 AllowOlder x <> AllowOlder y = AllowOlder (x <> y)
234
235 instance Monoid AllowNewer where
236 mempty = AllowNewer mempty
237 mappend = (<>)
238
239 instance Monoid AllowOlder where
240 mempty = AllowOlder mempty
241 mappend = (<>)