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