never executed always true always false
1 {-# LANGUAGE TupleSections #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3
4 module Conjure.Language.Domain.AddAttributes
5 ( allSupportedAttributes
6 , addAttributesToDomain
7 , mkMin, mkMax
8 ) where
9
10 -- conjure
11 import Conjure.Prelude
12 import Conjure.Language.Name
13 import Conjure.Language.Domain
14 import Conjure.Language.Pretty
15 import Conjure.Language.Lenses
16 import Conjure.Language.Definition
17 import Conjure.Language.Expression.Op
18
19 import Data.List as L ( union )
20
21 -- containers
22 import Data.Set as S ( singleton )
23
24
25 allSupportedAttributes :: [(Name, Int)]
26 allSupportedAttributes =
27 map (,1) [ "size", "minSize", "maxSize"
28 , "minOccur", "maxOccur"
29 , "numParts", "minNumParts", "maxNumParts"
30 , "partSize", "minPartSize", "maxPartSize"
31 ] ++
32 map (,0) [ "total"
33 , "injective", "surjective", "bijective"
34 , "regular"
35 ] ++
36 map (,0) [ "reflexive"
37 , "irreflexive"
38 , "coreflexive"
39 , "symmetric"
40 , "antiSymmetric"
41 , "aSymmetric"
42 , "transitive"
43 , "total"
44 , "connex"
45 , "Euclidean"
46 , "serial"
47 , "equivalence"
48 , "partialOrder"
49 ]
50
51
52 addAttributesToDomain
53 :: ( MonadFailDoc m
54 , Pretty r
55 )
56 => Domain r Expression
57 -> [(AttrName, Maybe Expression)]
58 -> m (Domain r Expression)
59 addAttributesToDomain domain [] = return domain
60 addAttributesToDomain domain ((attr, val) : rest) = do
61 domain' <- addAttributeToDomain domain attr val
62 addAttributesToDomain domain' rest
63
64
65 addAttributeToDomain
66 :: ( MonadFailDoc m
67 , Pretty r
68 )
69 => Domain r Expression -- the input domain
70 -> AttrName -- the name of the attribute
71 -> Maybe Expression -- the value for the attribute
72 -> m (Domain r Expression) -- the modified domain
73
74 addAttributeToDomain d@DomainAny{} = const $ const $ return d
75 addAttributeToDomain d@DomainBool{} = const $ const $ return d
76 addAttributeToDomain d@DomainIntE{} = const $ const $ return d
77 addAttributeToDomain d@DomainInt{} = const $ const $ return d
78 addAttributeToDomain d@DomainEnum{} = const $ const $ return d
79 addAttributeToDomain d@DomainUnnamed{} = const $ const $ return d
80 addAttributeToDomain d@DomainTuple{} = const $ const $ return d
81 addAttributeToDomain d@DomainRecord{} = const $ const $ return d
82 addAttributeToDomain d@DomainVariant{} = const $ const $ return d
83 addAttributeToDomain d@DomainMatrix{} = const $ const $ return d
84 addAttributeToDomain d@DomainOp{} = const $ const $ return d
85 addAttributeToDomain d@DomainReference{} = const $ const $ return d
86 addAttributeToDomain d@DomainMetaVar{} = const $ const $ return d
87 addAttributeToDomain d@DomainPermutation{} = const $ const $ return d
88
89 addAttributeToDomain domain@(DomainSet r (SetAttr sizeAttr) inner) = updater where
90 updater attr (Just val) = case attr of
91 AttrName_size ->
92 case sizeAttr of
93 SizeAttr_Size s | val == s -> return domain
94 SizeAttr_Size{} -> failDoc $ "Cannot add a size attribute to this domain:" <++> pretty domain
95 _ -> return $ DomainSet r (SetAttr (SizeAttr_Size val)) inner
96 AttrName_minSize -> do
97 let fails = failDoc $ "Cannot add a minSize attribute to this domain:" <++> pretty domain
98 case sizeAttr of
99 SizeAttr_Size s | val == s -> return domain
100 SizeAttr_Size{} -> fails
101 SizeAttr_MinSize minS -> return $ DomainSet r (SetAttr (SizeAttr_MinSize (mkMax minS val))) inner
102 SizeAttr_MaxSize maxS | val == maxS -> return $ DomainSet r (SetAttr (SizeAttr_Size val)) inner
103 SizeAttr_MaxSize maxS -> return $ DomainSet r (SetAttr (SizeAttr_MinMaxSize val maxS)) inner
104 SizeAttr_MinMaxSize _ maxS | val == maxS -> return $ DomainSet r (SetAttr (SizeAttr_Size val)) inner
105 SizeAttr_MinMaxSize minS maxS -> return $ DomainSet r (SetAttr (SizeAttr_MinMaxSize (mkMax minS val) maxS)) inner
106 SizeAttr_None{} -> return $ DomainSet r (SetAttr (SizeAttr_MinSize val)) inner
107 AttrName_maxSize -> do
108 let fails = failDoc $ "Cannot add a maxSize attribute to this domain:" <++> pretty domain
109 case sizeAttr of
110 SizeAttr_Size s | val == s -> return domain
111 SizeAttr_Size{} -> fails
112 SizeAttr_MinSize minS | val == minS -> return $ DomainSet r (SetAttr (SizeAttr_Size val)) inner
113 SizeAttr_MinSize minS -> return $ DomainSet r (SetAttr (SizeAttr_MinMaxSize minS val)) inner
114 SizeAttr_MaxSize maxS -> return $ DomainSet r (SetAttr (SizeAttr_MaxSize (mkMin maxS val))) inner
115 SizeAttr_MinMaxSize minS _ | val == minS -> return $ DomainSet r (SetAttr (SizeAttr_Size val)) inner
116 SizeAttr_MinMaxSize minS maxS -> return $ DomainSet r (SetAttr (SizeAttr_MinMaxSize minS (mkMin maxS val))) inner
117 SizeAttr_None{} -> return $ DomainSet r (SetAttr (SizeAttr_MaxSize val)) inner
118 _ ->
119 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
120 , "For the domain:" <+> pretty domain
121 ]
122 updater attr Nothing =
123 failDoc $ vcat [ "Missing attribute value for" <+> pretty attr
124 , "For the domain:" <+> pretty domain
125 ]
126
127 addAttributeToDomain domain@(DomainMSet r (MSetAttr sizeAttr occurAttr) inner) = updater where
128 updater attr (Just val) = case attr of
129 AttrName_size ->
130 case sizeAttr of
131 SizeAttr_Size s | val == s -> return domain
132 SizeAttr_Size{} -> failDoc $ "Cannot add a size attribute to this domain:" <++> pretty domain
133 _ -> return $ DomainMSet r (MSetAttr (SizeAttr_Size val) occurAttr) inner
134 AttrName_minSize -> do
135 let fails = failDoc $ "Cannot add a minSize attribute to this domain:" <++> pretty domain
136 case sizeAttr of
137 SizeAttr_Size s | val == s -> return domain
138 SizeAttr_Size{} -> fails
139 SizeAttr_MinSize minS -> return $ DomainMSet r
140 (MSetAttr (SizeAttr_MinSize (mkMax minS val)) occurAttr)
141 inner
142 SizeAttr_MaxSize maxS | val == maxS -> return $ DomainMSet r
143 (MSetAttr (SizeAttr_Size val) occurAttr)
144 inner
145 SizeAttr_MaxSize maxS -> return $ DomainMSet r
146 (MSetAttr (SizeAttr_MinMaxSize val maxS) occurAttr)
147 inner
148 SizeAttr_MinMaxSize _ maxS | val == maxS -> return $ DomainMSet r
149 (MSetAttr (SizeAttr_Size val) occurAttr)
150 inner
151 SizeAttr_MinMaxSize minS maxS -> return $ DomainMSet r
152 (MSetAttr (SizeAttr_MinMaxSize (mkMax minS val) maxS) occurAttr)
153 inner
154 SizeAttr_None{} -> return $ DomainMSet r
155 (MSetAttr (SizeAttr_MinSize val) occurAttr)
156 inner
157 AttrName_maxSize -> do
158 let fails = failDoc $ "Cannot add a maxSize attribute to this domain:" <++> pretty domain
159 case sizeAttr of
160 SizeAttr_Size s | val == s -> return domain
161 SizeAttr_Size{} -> fails
162 SizeAttr_MinSize minS | val == minS -> return $ DomainMSet r
163 (MSetAttr (SizeAttr_Size val) occurAttr)
164 inner
165 SizeAttr_MinSize minS -> return $ DomainMSet r
166 (MSetAttr (SizeAttr_MinMaxSize minS val) occurAttr)
167 inner
168 SizeAttr_MaxSize maxS -> return $ DomainMSet r
169 (MSetAttr (SizeAttr_MaxSize (mkMin maxS val)) occurAttr)
170 inner
171 SizeAttr_MinMaxSize minS _ | val == minS -> return $ DomainMSet r
172 (MSetAttr (SizeAttr_Size val) occurAttr)
173 inner
174 SizeAttr_MinMaxSize minS maxS -> return $ DomainMSet r
175 (MSetAttr (SizeAttr_MinMaxSize minS (mkMin maxS val)) occurAttr)
176 inner
177 SizeAttr_None{} -> return $ DomainMSet r
178 (MSetAttr (SizeAttr_MaxSize val) occurAttr)
179 inner
180 AttrName_minOccur ->
181 case occurAttr of
182 OccurAttr_MinOccur minO -> return $ DomainMSet r
183 (MSetAttr sizeAttr (OccurAttr_MinOccur (mkMax minO val)))
184 inner
185 OccurAttr_MaxOccur maxO -> return $ DomainMSet r
186 (MSetAttr sizeAttr (OccurAttr_MinMaxOccur val maxO))
187 inner
188 OccurAttr_MinMaxOccur minO maxO -> return $ DomainMSet r
189 (MSetAttr sizeAttr (OccurAttr_MinMaxOccur (mkMax minO val) maxO))
190 inner
191 OccurAttr_None -> return $ DomainMSet r
192 (MSetAttr sizeAttr (OccurAttr_MinOccur val))
193 inner
194 AttrName_maxOccur ->
195 case occurAttr of
196 OccurAttr_MinOccur minO -> return $ DomainMSet r
197 (MSetAttr sizeAttr (OccurAttr_MinMaxOccur minO val))
198 inner
199 OccurAttr_MaxOccur maxO -> return $ DomainMSet r
200 (MSetAttr sizeAttr (OccurAttr_MaxOccur (mkMin maxO val)))
201 inner
202 OccurAttr_MinMaxOccur minO maxO -> return $ DomainMSet r
203 (MSetAttr sizeAttr (OccurAttr_MinMaxOccur minO (mkMin maxO val)))
204 inner
205 OccurAttr_None -> return $ DomainMSet r
206 (MSetAttr sizeAttr (OccurAttr_MaxOccur val))
207 inner
208 _ ->
209 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
210 , "For the domain:" <+> pretty domain
211 ]
212 updater attr Nothing =
213 failDoc $ vcat [ "Missing attribute value for" <+> pretty attr
214 , "For the domain:" <+> pretty domain
215 ]
216
217 addAttributeToDomain domain@(DomainFunction r
218 (FunctionAttr sizeAttr partialityAttr jectivityAttr)
219 inF inT) = updater where
220 updater attr (Just val) = case attr of
221 AttrName_size ->
222 case sizeAttr of
223 SizeAttr_Size{} -> failDoc $ "Cannot add a size attribute to this domain:" <++> pretty domain
224 _ -> return $ DomainFunction r
225 (FunctionAttr (SizeAttr_Size val) partialityAttr jectivityAttr)
226 inF inT
227 AttrName_minSize -> do
228 let fails = failDoc $ "Cannot add a minSize attribute to this domain:" <++> pretty domain
229 case sizeAttr of
230 SizeAttr_Size{} -> fails
231 SizeAttr_MinSize{} -> fails
232 SizeAttr_MinMaxSize{} -> fails
233 SizeAttr_None{} -> return $ DomainFunction r
234 (FunctionAttr (SizeAttr_MinSize val) partialityAttr jectivityAttr)
235 inF inT
236 SizeAttr_MaxSize maxS -> return $ DomainFunction r
237 (FunctionAttr (SizeAttr_MinMaxSize val maxS) partialityAttr jectivityAttr)
238 inF inT
239 AttrName_maxSize -> do
240 let fails = failDoc $ "Cannot add a maxSize attribute to this domain:" <++> pretty domain
241 case sizeAttr of
242 SizeAttr_Size{} -> fails
243 SizeAttr_MaxSize{} -> fails
244 SizeAttr_MinMaxSize{} -> fails
245 SizeAttr_None{} -> return $ DomainFunction r
246 (FunctionAttr (SizeAttr_MaxSize val) partialityAttr jectivityAttr)
247 inF inT
248 SizeAttr_MinSize minS -> return $ DomainFunction r
249 (FunctionAttr (SizeAttr_MinMaxSize minS val) partialityAttr jectivityAttr)
250 inF inT
251 _ ->
252 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
253 , "For the domain:" <+> pretty domain
254 ]
255 updater "total" Nothing = return $ DomainFunction r
256 (FunctionAttr sizeAttr PartialityAttr_Total jectivityAttr)
257 inF inT
258 updater "injective" Nothing = return $
259 case jectivityAttr of
260 JectivityAttr_None -> DomainFunction r
261 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Injective )
262 inF inT
263 JectivityAttr_Injective -> DomainFunction r
264 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Injective )
265 inF inT
266 JectivityAttr_Surjective -> DomainFunction r
267 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Bijective )
268 inF inT
269 JectivityAttr_Bijective -> DomainFunction r
270 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Bijective )
271 inF inT
272 updater "surjective" Nothing = return $
273 case jectivityAttr of
274 JectivityAttr_None -> DomainFunction r
275 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Surjective)
276 inF inT
277 JectivityAttr_Injective -> DomainFunction r
278 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Bijective )
279 inF inT
280 JectivityAttr_Surjective -> DomainFunction r
281 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Surjective)
282 inF inT
283 JectivityAttr_Bijective -> DomainFunction r
284 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Bijective )
285 inF inT
286 updater "bijective" Nothing = return $ DomainFunction r
287 (FunctionAttr sizeAttr partialityAttr JectivityAttr_Bijective)
288 inF inT
289 updater attr _ =
290 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
291 , "For the domain:" <+> pretty domain
292 ]
293
294 addAttributeToDomain domain@(DomainSequence r
295 (SequenceAttr sizeAttr jectivityAttr)
296 inner) = updater where
297 updater attr (Just val) = case attr of
298 AttrName_size ->
299 case sizeAttr of
300 SizeAttr_Size{} -> failDoc $ "Cannot add a size attribute to this domain:" <++> pretty domain
301 _ -> return $ DomainSequence r
302 (SequenceAttr (SizeAttr_Size val) jectivityAttr)
303 inner
304 AttrName_minSize -> do
305 let fails = failDoc $ "Cannot add a minSize attribute to this domain:" <++> pretty domain
306 case sizeAttr of
307 SizeAttr_Size{} -> fails
308 SizeAttr_MinSize{} -> fails
309 SizeAttr_MinMaxSize{} -> fails
310 SizeAttr_None{} -> return $ DomainSequence r
311 (SequenceAttr (SizeAttr_MinSize val) jectivityAttr)
312 inner
313 SizeAttr_MaxSize maxS -> return $ DomainSequence r
314 (SequenceAttr (SizeAttr_MinMaxSize val maxS) jectivityAttr)
315 inner
316 AttrName_maxSize -> do
317 let fails = failDoc $ "Cannot add a maxSize attribute to this domain:" <++> pretty domain
318 case sizeAttr of
319 SizeAttr_Size{} -> fails
320 SizeAttr_MaxSize{} -> fails
321 SizeAttr_MinMaxSize{} -> fails
322 SizeAttr_None{} -> return $ DomainSequence r
323 (SequenceAttr (SizeAttr_MaxSize val) jectivityAttr)
324 inner
325 SizeAttr_MinSize minS -> return $ DomainSequence r
326 (SequenceAttr (SizeAttr_MinMaxSize minS val) jectivityAttr)
327 inner
328 _ ->
329 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
330 , "For the domain:" <+> pretty domain
331 ]
332 updater "injective" Nothing = return $
333 case jectivityAttr of
334 JectivityAttr_None -> DomainSequence r
335 (SequenceAttr sizeAttr JectivityAttr_Injective )
336 inner
337 JectivityAttr_Injective -> DomainSequence r
338 (SequenceAttr sizeAttr JectivityAttr_Injective )
339 inner
340 JectivityAttr_Surjective -> DomainSequence r
341 (SequenceAttr sizeAttr JectivityAttr_Bijective )
342 inner
343 JectivityAttr_Bijective -> DomainSequence r
344 (SequenceAttr sizeAttr JectivityAttr_Bijective )
345 inner
346 updater "surjective" Nothing = return $
347 case jectivityAttr of
348 JectivityAttr_None -> DomainSequence r
349 (SequenceAttr sizeAttr JectivityAttr_Surjective)
350 inner
351 JectivityAttr_Injective -> DomainSequence r
352 (SequenceAttr sizeAttr JectivityAttr_Bijective )
353 inner
354 JectivityAttr_Surjective -> DomainSequence r
355 (SequenceAttr sizeAttr JectivityAttr_Surjective)
356 inner
357 JectivityAttr_Bijective -> DomainSequence r
358 (SequenceAttr sizeAttr JectivityAttr_Bijective )
359 inner
360 updater "bijective" Nothing = return $ DomainSequence r
361 (SequenceAttr sizeAttr JectivityAttr_Bijective)
362 inner
363 updater attr _ =
364 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
365 , "For the domain:" <+> pretty domain
366 ]
367
368 addAttributeToDomain domain@(DomainRelation r
369 (RelationAttr sizeAttr binRelAttr)
370 inners) = updater where
371 supportedBinRel :: [AttrName]
372 supportedBinRel =
373 [ "reflexive", "irreflexive", "coreflexive"
374 , "symmetric", "antiSymmetric", "aSymmetric"
375 , "transitive", "total", "connex", "Euclidean"
376 , "serial", "equivalence", "partialOrder"
377 ]
378 updater attr (Just val) = case attr of
379 AttrName_size ->
380 case sizeAttr of
381 SizeAttr_Size{} -> failDoc $ "Cannot add a size attribute to this domain:" <++> pretty domain
382 _ -> return $ DomainRelation r (RelationAttr (SizeAttr_Size val) binRelAttr) inners
383 AttrName_minSize -> do
384 let fails = failDoc $ "Cannot add a minSize attribute to this domain:" <++> pretty domain
385 case sizeAttr of
386 SizeAttr_Size{} -> fails
387 SizeAttr_MinSize{} -> fails
388 SizeAttr_MinMaxSize{} -> fails
389 SizeAttr_None{} -> return $ DomainRelation r
390 (RelationAttr (SizeAttr_MinSize val) binRelAttr)
391 inners
392 SizeAttr_MaxSize maxS -> return $ DomainRelation r
393 (RelationAttr (SizeAttr_MinMaxSize val maxS) binRelAttr)
394 inners
395 AttrName_maxSize -> do
396 let fails = failDoc $ "Cannot add a maxSize attribute to this domain:" <++> pretty domain
397 case sizeAttr of
398 SizeAttr_Size{} -> fails
399 SizeAttr_MaxSize{} -> fails
400 SizeAttr_MinMaxSize{} -> fails
401 SizeAttr_None{} -> return $ DomainRelation r
402 (RelationAttr (SizeAttr_MaxSize val) binRelAttr)
403 inners
404 SizeAttr_MinSize minS -> return $ DomainRelation r
405 (RelationAttr (SizeAttr_MinMaxSize minS val) binRelAttr)
406 inners
407 _ ->
408 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
409 , "For the domain:" <+> pretty domain
410 ]
411 updater attr Nothing | attr `elem` supportedBinRel = case readBinRel attr of
412 Nothing ->
413 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
414 , "For the domain:" <+> pretty domain
415 ]
416 Just a -> return $ DomainRelation r
417 (RelationAttr sizeAttr (binRelAttr `mappend` BinaryRelationAttrs (S.singleton a)))
418 inners
419 updater attr _ =
420 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
421 , "For the domain:" <+> pretty domain
422 ]
423
424 addAttributeToDomain domain@(DomainPartition r partitionAttr inner) = updater where
425 updater attr (Just val) = case attr of
426
427 AttrName_numParts ->
428 case partsNum partitionAttr of
429 SizeAttr_Size s | val == s -> return domain
430 SizeAttr_Size{} -> failDoc $ "Cannot add a numParts attribute to this domain:" <++> pretty domain
431 _ -> return $ DomainPartition r (partitionAttr { partsNum = SizeAttr_Size val }) inner
432 AttrName_minNumParts -> do
433 let fails = failDoc $ "Cannot add a minNumParts attribute to this domain:" <++> pretty domain
434 case partsNum partitionAttr of
435 SizeAttr_Size s | val == s -> return domain
436 SizeAttr_Size{} -> fails
437 SizeAttr_MinSize minS -> return $ DomainPartition r
438 partitionAttr { partsNum = SizeAttr_MinSize (mkMax minS val) }
439 inner
440 SizeAttr_MaxSize maxS | val == maxS -> return $ DomainPartition r
441 partitionAttr { partsNum = SizeAttr_Size val }
442 inner
443 SizeAttr_MaxSize maxS -> return $ DomainPartition r
444 partitionAttr { partsNum = SizeAttr_MinMaxSize val maxS }
445 inner
446 SizeAttr_MinMaxSize _ maxS | val == maxS -> return $ DomainPartition r
447 partitionAttr { partsNum = SizeAttr_Size val }
448 inner
449 SizeAttr_MinMaxSize minS maxS -> return $ DomainPartition r
450 partitionAttr { partsNum = SizeAttr_MinMaxSize (mkMax minS val) maxS }
451 inner
452 SizeAttr_None{} -> return $ DomainPartition r
453 partitionAttr { partsNum = SizeAttr_MinSize val }
454 inner
455 AttrName_maxNumParts -> do
456 let fails = failDoc $ "Cannot add a maxNumParts attribute to this domain:" <++> pretty domain
457 case partsNum partitionAttr of
458 SizeAttr_Size s | val == s -> return domain
459 SizeAttr_Size{} -> fails
460 SizeAttr_MinSize minS | val == minS -> return $ DomainPartition r
461 partitionAttr { partsNum = SizeAttr_Size val }
462 inner
463 SizeAttr_MinSize minS -> return $ DomainPartition r
464 partitionAttr { partsNum = SizeAttr_MinMaxSize minS val }
465 inner
466 SizeAttr_MaxSize maxS -> return $ DomainPartition r
467 partitionAttr { partsNum = SizeAttr_MaxSize (mkMin maxS val) }
468 inner
469 SizeAttr_MinMaxSize minS _ | val == minS -> return $ DomainPartition r
470 partitionAttr { partsNum = SizeAttr_Size val }
471 inner
472 SizeAttr_MinMaxSize minS maxS -> return $ DomainPartition r
473 partitionAttr { partsNum = SizeAttr_MinMaxSize minS (mkMin maxS val) }
474 inner
475 SizeAttr_None{} -> return $ DomainPartition r
476 partitionAttr { partsNum = SizeAttr_MaxSize val }
477 inner
478
479 AttrName_partSize ->
480 case partsSize partitionAttr of
481 SizeAttr_Size s | val == s -> return domain
482 SizeAttr_Size{} -> failDoc $ "Cannot add a partSize attribute to this domain:" <++> pretty domain
483 _ -> return $ DomainPartition r (partitionAttr { partsSize = SizeAttr_Size val }) inner
484 AttrName_minPartSize -> do
485 let fails = failDoc $ "Cannot add a minPartSize attribute to this domain:" <++> pretty domain
486 case partsSize partitionAttr of
487 SizeAttr_Size s | val == s -> return domain
488 SizeAttr_Size{} -> fails
489 SizeAttr_MinSize minS -> return $ DomainPartition r
490 partitionAttr { partsSize = SizeAttr_MinSize (mkMax minS val) }
491 inner
492 SizeAttr_MaxSize maxS | val == maxS -> return $ DomainPartition r
493 partitionAttr { partsSize = SizeAttr_Size val }
494 inner
495 SizeAttr_MaxSize maxS -> return $ DomainPartition r
496 partitionAttr { partsSize = SizeAttr_MinMaxSize val maxS }
497 inner
498 SizeAttr_MinMaxSize _ maxS | val == maxS -> return $ DomainPartition r
499 partitionAttr { partsSize = SizeAttr_Size val }
500 inner
501 SizeAttr_MinMaxSize minS maxS -> return $ DomainPartition r
502 partitionAttr { partsSize = SizeAttr_MinMaxSize (mkMax minS val) maxS }
503 inner
504 SizeAttr_None{} -> return $ DomainPartition r
505 (partitionAttr { partsSize = SizeAttr_MinSize val })
506 inner
507 AttrName_maxPartSize -> do
508 let fails = failDoc $ "Cannot add a maxPartSize attribute to this domain:" <++> pretty domain
509 case partsSize partitionAttr of
510 SizeAttr_Size s | val == s -> return domain
511 SizeAttr_Size{} -> fails
512 SizeAttr_MinSize minS | val == minS -> return $ DomainPartition r
513 partitionAttr { partsSize = SizeAttr_Size val }
514 inner
515 SizeAttr_MinSize minS -> return $ DomainPartition r
516 partitionAttr { partsSize = SizeAttr_MinMaxSize minS val }
517 inner
518 SizeAttr_MaxSize maxS -> return $ DomainPartition r
519 partitionAttr { partsSize = SizeAttr_MaxSize (mkMin maxS val) }
520 inner
521 SizeAttr_MinMaxSize minS _ | val == minS -> return $ DomainPartition r
522 partitionAttr { partsSize = SizeAttr_Size val }
523 inner
524 SizeAttr_MinMaxSize minS maxS -> return $ DomainPartition r
525 partitionAttr { partsSize = SizeAttr_MinMaxSize minS (mkMin maxS val) }
526 inner
527 SizeAttr_None{} -> return $ DomainPartition r
528 (partitionAttr { partsSize = SizeAttr_MaxSize val })
529 inner
530
531 _ ->
532 failDoc $ vcat [ "Unsupported attribute" <+> pretty attr
533 , "For the domain:" <+> pretty domain
534 ]
535 updater AttrName_regular Nothing =
536 return $ DomainPartition r (partitionAttr { isRegular = True }) inner
537 updater attr Nothing =
538 failDoc $ vcat [ "Missing attribute value for" <+> pretty attr
539 , "For the domain:" <+> pretty domain
540 ]
541
542
543 -- | Make a maximum expression between two expressions.
544 -- | Two max expressions are merged into one.
545 -- | The max between a value and a max adds the value to the max (if not present).
546 -- | If the expressions are the same, no max is made and the value is returned.
547 mkMax :: Expression -> Expression -> Expression
548 mkMax (Op (MkOpMax (OpMax (AbstractLiteral (AbsLitMatrix _ es1)))))
549 (Op (MkOpMax (OpMax (AbstractLiteral (AbsLitMatrix _ es2)))))
550 = make opMax $ fromList $ es1 `L.union` es2
551 mkMax i m@(Op (MkOpMax (OpMax (AbstractLiteral (AbsLitMatrix _ es)))))
552 | i `elem` es = m
553 | otherwise = make opMax $ fromList $ i : es
554 mkMax m@(Op (MkOpMax (OpMax (AbstractLiteral (AbsLitMatrix _ es))))) i
555 | i `elem` es = m
556 | otherwise = make opMax $ fromList $ i : es
557 mkMax i e | i == e = e
558 | otherwise = make opMax $ fromList [ i, e ]
559
560 -- | Make a minimum expression between two expressions.
561 -- | Two min expressions are merged into one.
562 -- | The min between a value and a min adds the value to the min (if not present).
563 -- | If the expressions are the same, no min is made and the value is returned.
564 mkMin :: Expression -> Expression -> Expression
565 mkMin (Op (MkOpMin (OpMin (AbstractLiteral (AbsLitMatrix _ es1)))))
566 (Op (MkOpMin (OpMin (AbstractLiteral (AbsLitMatrix _ es2)))))
567 = make opMin $ fromList $ es1 `L.union` es2
568 mkMin i m@(Op (MkOpMin (OpMin (AbstractLiteral (AbsLitMatrix _ es)))))
569 | i `elem` es = m
570 | otherwise = make opMin $ fromList $ i : es
571 mkMin m@(Op (MkOpMin (OpMin (AbstractLiteral (AbsLitMatrix _ es))))) i
572 | i `elem` es = m
573 | otherwise = make opMin $ fromList $ i : es
574 mkMin i e | i == e = e
575 | otherwise = make opMin $ fromList [ i, e ]