never executed always true always false
1 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DeriveFunctor, DeriveTraversable, DeriveFoldable #-}
2 {-# LANGUAGE TupleSections #-}
3 {-# LANGUAGE NoMonomorphismRestriction #-}
4
5 module Conjure.Language.Domain
6 ( Domain(..)
7 , HasRepresentation(..)
8 , Range(..), rangesInts
9 , SetAttr(..), SizeAttr(..), getMaxFrom_SizeAttr, intersectSizeAttr
10 , MSetAttr(..), OccurAttr(..), getMaxFrom_OccurAttr
11 , FunctionAttr(..), PartialityAttr(..), JectivityAttr(..)
12 , SequenceAttr(..)
13 , RelationAttr(..), BinaryRelationAttrs(..), BinaryRelationAttr(..), binRelNames
14 , PartitionAttr(..)
15 , AttrName(..)
16 , DomainAttributes(..), DomainAttribute(..) -- only for parsing
17 , textToRepresentation, representationToShortText, representationToFullText
18 , isPrimitiveDomain, domainCanIndexMatrix, expandDomainReference, getIndices
19 , Tree(..), reprTree, reprAtTopLevel, applyReprTree
20 , reprTreeEncoded
21 , forgetRepr, changeRepr, defRepr
22 , mkDomainBool, mkDomainInt, mkDomainIntB, mkDomainIntBTagged, mkDomainAny
23 , typeOfDomain
24 , readBinRel, binRelToAttrName
25 , normaliseDomain, normaliseRange
26 , innerDomainOf
27 , singletonDomainInt
28 , matrixNumDimsD
29 ) where
30
31 -- conjure
32 import Conjure.Prelude
33 import Conjure.Bug
34 import Conjure.Language.Name
35 import Conjure.Language.Type
36 import Conjure.Language.TypeOf
37 import Conjure.Language.AdHoc
38 import Conjure.Language.Pretty
39
40 -- base
41 import qualified Data.Semigroup as Semigroup ( (<>) )
42
43 -- QuickCheck
44 import Test.QuickCheck ( Arbitrary(..), choose, oneof, vectorOf, sized )
45
46 -- containers
47 import Data.Set as S ( Set, empty, toList, union )
48
49 -- syb
50 import Data.Data ( toConstr, constrIndex )
51
52
53 data Domain r x
54 = DomainAny Text Type
55 | DomainBool
56 | DomainIntE x
57 | DomainInt IntTag [Range x]
58 | DomainEnum
59 Name
60 (Maybe [Range x]) -- subset of values for this domain
61 -- Nothing *only* when GivenDomainDefnEnum and not LettingDomainDefnEnum
62 (Maybe [(Name, Integer)]) -- the mapping to integers, if available
63 | DomainUnnamed Name x
64 | DomainTuple [Domain r x]
65 | DomainRecord [(Name, Domain r x)]
66 | DomainVariant [(Name, Domain r x)]
67 | DomainMatrix (Domain () x) (Domain r x)
68 | DomainSet r (SetAttr x) (Domain r x)
69 | DomainMSet r (MSetAttr x) (Domain r x)
70 | DomainFunction r (FunctionAttr x) (Domain r x) (Domain r x)
71 | DomainSequence r (SequenceAttr x) (Domain r x)
72 | DomainRelation r (RelationAttr x) [Domain r x]
73 | DomainPartition r (PartitionAttr x) (Domain r x)
74 | DomainOp Name [Domain r x]
75 | DomainReference Name (Maybe (Domain r x))
76 | DomainMetaVar String
77 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
78
79 instance (VarSymBreakingDescription x, ToJSON r) => VarSymBreakingDescription (Domain r x) where
80 varSymBreakingDescription domain = toJSON $ fmap varSymBreakingDescription domain
81
82 mkDomainBool :: Domain () x
83 mkDomainBool = DomainBool
84
85 mkDomainInt :: [Range x] -> Domain () x
86 mkDomainInt = DomainInt TagInt
87
88 mkDomainIntB :: x -> x -> Domain () x
89 mkDomainIntB l u = DomainInt TagInt [RangeBounded l u]
90
91 mkDomainIntBTagged :: IntTag -> x -> x -> Domain () x
92 mkDomainIntBTagged t l u = DomainInt t [RangeBounded l u]
93
94 mkDomainAny :: Doc -> Type -> Domain r x
95 mkDomainAny reason = DomainAny (stringToText $ show reason)
96
97 instance (Serialize r, Serialize x) => Serialize (Domain r x)
98 instance (Hashable r, Hashable x) => Hashable (Domain r x)
99 instance (ToJSON r, ToJSON x) => ToJSON (Domain r x) where toJSON = genericToJSON jsonOptions
100 instance (FromJSON r, FromJSON x) => FromJSON (Domain r x) where parseJSON = genericParseJSON jsonOptions
101
102 instance Arbitrary x => Arbitrary (Domain r x) where
103 arbitrary = sized f
104 where
105 f 0 = oneof [ return DomainBool
106 , DomainInt TagInt <$> arbitrary
107 -- , DomainEnum <$> arbitrary <*> arbitrary
108 ]
109 f s = do
110 arity <- choose (2 :: Int, 10)
111 DomainTuple <$> vectorOf arity (f (div s 10))
112 shrink DomainBool = []
113 shrink (DomainInt _ []) = [DomainBool]
114 shrink (DomainInt t [r]) = DomainBool : DomainInt t [] : [DomainInt t [r'] | r' <- shrink r]
115 shrink (DomainInt t rs) = [DomainInt t (init rs)]
116 shrink _ = []
117
118
119 typeOfDomain ::
120 MonadFailDoc m =>
121 Pretty r =>
122 TypeOf x =>
123 Pretty x =>
124 (?typeCheckerMode :: TypeCheckerMode) =>
125 Domain r x -> m Type
126 typeOfDomain (DomainAny _ ty) = return ty
127 typeOfDomain DomainBool = return TypeBool
128 typeOfDomain d@(DomainIntE x) = do
129 ty <- typeOf x
130 case ty of
131 TypeInt TagInt -> return () -- pre recoverDomainInt
132 TypeList (TypeInt TagInt) -> return ()
133 TypeMatrix _ (TypeInt TagInt) -> return ()
134 TypeSet (TypeInt TagInt) -> return ()
135 _ -> failDoc $ vcat [ "Expected an integer, but got:" <++> pretty ty
136 , "In domain:" <+> pretty d
137 ]
138 return (TypeInt TagInt)
139 typeOfDomain d@(DomainInt t rs) = do
140 forM_ rs $ \ r -> forM_ r $ \ x -> do
141 ty <- typeOf x
142 case ty of
143 TypeInt{} -> return ()
144 _ -> failDoc $ vcat [ "Expected an integer, but got:" <++> pretty ty
145 , "For:" <+> pretty x
146 , "In domain:" <+> pretty d
147 ]
148 return (TypeInt t)
149 typeOfDomain (DomainEnum defn _ _ ) = return (TypeEnum defn)
150 typeOfDomain (DomainUnnamed defn _ ) = return (TypeUnnamed defn)
151 typeOfDomain (DomainTuple xs ) = TypeTuple <$> mapM typeOfDomain xs
152 typeOfDomain (DomainRecord xs ) = TypeRecord <$> sequence [ do t <- typeOfDomain d ; return (n, t)
153 | (n,d) <- xs ]
154 typeOfDomain (DomainVariant xs ) = TypeVariant <$> sequence [ do t <- typeOfDomain d ; return (n, t)
155 | (n,d) <- xs ]
156 typeOfDomain (DomainMatrix ind inn ) = TypeMatrix <$> typeOfDomain ind <*> typeOfDomain inn
157 typeOfDomain (DomainSet _ _ x ) = TypeSet <$> typeOfDomain x
158 typeOfDomain (DomainMSet _ _ x ) = TypeMSet <$> typeOfDomain x
159 typeOfDomain (DomainFunction _ _ x y) = TypeFunction <$> typeOfDomain x <*> typeOfDomain y
160 typeOfDomain (DomainSequence _ _ x ) = TypeSequence <$> typeOfDomain x
161 typeOfDomain (DomainRelation _ _ xs ) = TypeRelation <$> mapM typeOfDomain xs
162 typeOfDomain (DomainPartition _ _ x ) = TypePartition <$> typeOfDomain x
163 typeOfDomain p@(DomainOp _ ds) = do
164 ts <- mapM typeOfDomain ds
165 if typesUnify ts
166 then return (mostDefined ts)
167 else failDoc ("Type error in" <+> pretty p)
168 typeOfDomain (DomainReference _ (Just d)) = typeOfDomain d
169 typeOfDomain (DomainReference nm Nothing) = bug $ "typeOfDomain: DomainReference" <+> pretty nm
170 typeOfDomain (DomainMetaVar nm) = bug $ "typeOfDomain: DomainMetaVar &" <> pretty nm
171
172 forgetRepr :: Domain r x -> Domain () x
173 forgetRepr = defRepr
174
175 defRepr :: Default r2 => Domain r x -> Domain r2 x
176 defRepr = changeRepr def
177
178 changeRepr :: r2 -> Domain r x -> Domain r2 x
179 changeRepr rep = go
180 where
181 go (DomainAny t ty) = DomainAny t ty
182 go DomainBool = DomainBool
183 go (DomainIntE x) = DomainIntE x
184 go (DomainInt t rs) = DomainInt t rs
185 go (DomainEnum defn rs mp) = DomainEnum defn rs mp
186 go (DomainUnnamed defn s) = DomainUnnamed defn s
187 go (DomainTuple ds) = DomainTuple (map go ds)
188 go (DomainRecord xs) = DomainRecord (map (second go) xs)
189 go (DomainVariant xs) = DomainVariant (map (second go) xs)
190 go (DomainMatrix index inner) = DomainMatrix index (go inner)
191 go (DomainSet _ attr d) =
192 DomainSet rep attr (go d)
193 go (DomainMSet _ attr d) =
194 DomainMSet rep attr (go d)
195 go (DomainFunction _ attr d1 d2) =
196 DomainFunction rep attr (go d1) (go d2)
197 go (DomainSequence _ attr d) =
198 DomainSequence rep attr (go d)
199 go (DomainRelation _ attr ds) =
200 DomainRelation rep attr (map go ds)
201 go (DomainPartition _ attr d) =
202 DomainPartition rep attr (go d)
203 go (DomainOp op ds) = DomainOp op (map go ds)
204 go (DomainReference x r) = DomainReference x (fmap go r)
205 go (DomainMetaVar x) = DomainMetaVar x
206
207
208 data Tree a = Tree { rootLabel :: a, subForest :: [Tree a] }
209 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
210
211 instance Serialize a => Serialize (Tree a)
212 instance Hashable a => Hashable (Tree a)
213 instance ToJSON a => ToJSON (Tree a) where toJSON = genericToJSON jsonOptions
214 instance FromJSON a => FromJSON (Tree a) where parseJSON = genericParseJSON jsonOptions
215
216 -- | This is to be used when defining `Conjure.Representations.Internal.mkOutName`.
217 -- Reason is to avoid sharing variables for parts of the same decision variable with differing representations.
218 -- Example case:
219 -- (1) find x : set {A} of (int(a..b) , set {B} of int(c..d))
220 -- (2) find x : set {A} of (int(a..b) , set {C} of int(c..d))
221 -- Here x_1's should not be shared!
222 -- If they are, the channelling and symmetry breaking constraints will clash and solutions will be lost.
223 reprTreeEncoded :: Domain HasRepresentation x -> Text
224 reprTreeEncoded = mconcat . enc1 . reprTree
225 where
226 enc1 (Tree lbl sub) =
227 maybe
228 (bug "reprTreeEncoded: top-most representation is Nothing")
229 representationToShortText
230 lbl
231 : concatMap enc sub
232 enc (Tree lbl sub) =
233 maybe [] representationConstrIndex lbl
234 ++ concatMap enc sub
235
236 reprTree :: Domain r x -> Tree (Maybe r)
237 reprTree DomainAny{} = Tree Nothing []
238 reprTree DomainBool{} = Tree Nothing []
239 reprTree DomainIntE{} = Tree Nothing []
240 reprTree DomainInt{} = Tree Nothing []
241 reprTree DomainEnum{} = Tree Nothing []
242 reprTree DomainUnnamed{} = Tree Nothing []
243 reprTree (DomainTuple as ) = Tree Nothing (map reprTree as)
244 reprTree (DomainRecord as ) = Tree Nothing (map (reprTree . snd) as)
245 reprTree (DomainVariant as) = Tree Nothing (map (reprTree . snd) as)
246 reprTree (DomainMatrix _ a) = Tree Nothing [reprTree a]
247 reprTree (DomainSet r _ a ) = Tree (Just r) [reprTree a]
248 reprTree (DomainMSet r _ a ) = Tree (Just r) [reprTree a]
249 reprTree (DomainFunction r _ a b) = Tree (Just r) [reprTree a, reprTree b]
250 reprTree (DomainSequence r _ a ) = Tree (Just r) [reprTree a]
251 reprTree (DomainRelation r _ as ) = Tree (Just r) (map reprTree as)
252 reprTree (DomainPartition r _ a ) = Tree (Just r) [reprTree a]
253 reprTree DomainOp{} = Tree Nothing []
254 reprTree DomainReference{} = Tree Nothing []
255 reprTree DomainMetaVar{} = Tree Nothing []
256
257 reprAtTopLevel :: Domain r x -> Maybe r
258 reprAtTopLevel = rootLabel . reprTree
259
260 applyReprTree :: (MonadFailDoc m, Pretty x, Pretty r2, Default r) => Domain r2 x -> Tree (Maybe r) -> m (Domain r x)
261 applyReprTree dom@DomainBool{} (Tree Nothing []) = return (defRepr dom)
262 applyReprTree dom@DomainInt{} (Tree Nothing []) = return (defRepr dom)
263 applyReprTree dom@DomainIntE{} (Tree Nothing []) = return (defRepr dom)
264 applyReprTree dom@DomainEnum{} (Tree Nothing []) = return (defRepr dom)
265 applyReprTree dom@DomainUnnamed{} (Tree Nothing []) = return (defRepr dom)
266 applyReprTree (DomainTuple as ) (Tree Nothing asRepr) =
267 DomainTuple <$> zipWithM applyReprTree as asRepr
268 applyReprTree (DomainRecord as ) (Tree Nothing asRepr) =
269 DomainRecord . zip (map fst as) <$> zipWithM applyReprTree (map snd as) asRepr
270 applyReprTree (DomainVariant as) (Tree Nothing asRepr) =
271 DomainVariant . zip (map fst as) <$> zipWithM applyReprTree (map snd as) asRepr
272 applyReprTree (DomainMatrix b a) (Tree Nothing [aRepr]) = DomainMatrix b <$> applyReprTree a aRepr
273 applyReprTree (DomainSet _ attr a ) (Tree (Just r) [aRepr]) = DomainSet r attr <$> applyReprTree a aRepr
274 applyReprTree (DomainMSet _ attr a ) (Tree (Just r) [aRepr]) = DomainMSet r attr <$> applyReprTree a aRepr
275 applyReprTree (DomainFunction _ attr a b) (Tree (Just r) [aRepr, bRepr]) = DomainFunction r attr <$> applyReprTree a aRepr <*> applyReprTree b bRepr
276 applyReprTree (DomainSequence _ attr a ) (Tree (Just r) [aRepr]) = DomainSequence r attr <$> applyReprTree a aRepr
277 applyReprTree (DomainRelation _ attr as ) (Tree (Just r) asRepr) = DomainRelation r attr <$> zipWithM applyReprTree as asRepr
278 applyReprTree (DomainPartition _ attr a ) (Tree (Just r) [aRepr]) = DomainPartition r attr <$> applyReprTree a aRepr
279 applyReprTree dom@DomainOp{} (Tree Nothing []) = return (defRepr dom)
280 applyReprTree dom@DomainReference{} (Tree Nothing []) = return (defRepr dom)
281 applyReprTree dom@DomainMetaVar{} (Tree Nothing []) = return (defRepr dom)
282 applyReprTree dom _ = failDoc $ "applyReprTree:" <++> pretty dom
283
284 isPrimitiveDomain :: Domain r x -> Bool
285 isPrimitiveDomain DomainBool{} = True
286 isPrimitiveDomain DomainIntE{} = True
287 isPrimitiveDomain DomainInt{} = True
288 isPrimitiveDomain (DomainMatrix index inner) = and [isPrimitiveDomain index, isPrimitiveDomain inner]
289 isPrimitiveDomain _ = False
290
291 getIndices :: Domain r x -> ([Domain () x], Domain r x)
292 getIndices (DomainMatrix index inner) = first (index:) (getIndices inner)
293 getIndices d = ([], d)
294
295 domainCanIndexMatrix :: Domain r x -> Bool
296 domainCanIndexMatrix (DomainReference _ (Just d)) = domainCanIndexMatrix d
297 domainCanIndexMatrix DomainBool{} = True
298 domainCanIndexMatrix DomainInt {} = True
299 domainCanIndexMatrix DomainIntE{} = True
300 domainCanIndexMatrix DomainEnum{} = True
301 domainCanIndexMatrix _ = False
302
303 expandDomainReference :: Data r => Data x => Domain r x -> Domain r x
304 expandDomainReference (DomainReference _ (Just d)) = expandDomainReference d
305 expandDomainReference d = descend expandDomainReference d
306
307
308 --------------------------------------------------------------------------------
309 -- attribute-as-constraint handling --------------------------------------------
310 --------------------------------------------------------------------------------
311
312 data AttrName
313 = AttrName_size
314 | AttrName_minSize
315 | AttrName_maxSize
316 | AttrName_minOccur
317 | AttrName_maxOccur
318 | AttrName_numParts
319 | AttrName_minNumParts
320 | AttrName_maxNumParts
321 | AttrName_partSize
322 | AttrName_minPartSize
323 | AttrName_maxPartSize
324 | AttrName_total
325 | AttrName_injective
326 | AttrName_surjective
327 | AttrName_bijective
328 | AttrName_regular
329 -- bin rel ones
330 | AttrName_reflexive
331 | AttrName_irreflexive
332 | AttrName_coreflexive
333 | AttrName_symmetric
334 | AttrName_antiSymmetric
335 | AttrName_aSymmetric
336 | AttrName_transitive
337 | AttrName_leftTotal
338 | AttrName_rightTotal
339 | AttrName_connex
340 | AttrName_Euclidean
341 | AttrName_serial
342 | AttrName_equivalence
343 | AttrName_partialOrder
344 | AttrName_linearOrder
345 | AttrName_weakOrder
346 | AttrName_preOrder
347 | AttrName_strictPartialOrder
348 deriving (Eq, Ord, Show, Data, Typeable, Generic)
349
350 instance Serialize AttrName
351 instance Hashable AttrName
352 instance ToJSON AttrName where toJSON = genericToJSON jsonOptions
353 instance FromJSON AttrName where parseJSON = genericParseJSON jsonOptions
354
355 instance Pretty AttrName where
356 pretty AttrName_size = "size"
357 pretty AttrName_minSize = "minSize"
358 pretty AttrName_maxSize = "maxSize"
359 pretty AttrName_minOccur = "minOccur"
360 pretty AttrName_maxOccur = "maxOccur"
361 pretty AttrName_numParts = "numParts"
362 pretty AttrName_minNumParts = "minNumParts"
363 pretty AttrName_maxNumParts = "maxNumParts"
364 pretty AttrName_partSize = "partSize"
365 pretty AttrName_minPartSize = "minPartSize"
366 pretty AttrName_maxPartSize = "maxPartSize"
367 pretty AttrName_total = "total"
368 pretty AttrName_injective = "injective"
369 pretty AttrName_surjective = "surjective"
370 pretty AttrName_bijective = "bijective"
371 pretty AttrName_regular = "regular"
372 pretty AttrName_reflexive = "reflexive"
373 pretty AttrName_irreflexive = "irreflexive"
374 pretty AttrName_coreflexive = "coreflexive"
375 pretty AttrName_symmetric = "symmetric"
376 pretty AttrName_antiSymmetric = "antiSymmetric"
377 pretty AttrName_aSymmetric = "aSymmetric"
378 pretty AttrName_transitive = "transitive"
379 pretty AttrName_leftTotal = "leftTotal"
380 pretty AttrName_rightTotal = "rightTotal"
381 pretty AttrName_connex = "connex"
382 pretty AttrName_Euclidean = "Euclidean"
383 pretty AttrName_serial = "serial"
384 pretty AttrName_equivalence = "equivalence"
385 pretty AttrName_partialOrder = "partialOrder"
386 pretty AttrName_linearOrder = "linearOrder"
387 pretty AttrName_weakOrder = "weakOrder"
388 pretty AttrName_preOrder = "preOrder"
389 pretty AttrName_strictPartialOrder = "strictPartialOrder"
390
391 instance IsString AttrName where
392 fromString "size" = AttrName_size
393 fromString "minSize" = AttrName_minSize
394 fromString "maxSize" = AttrName_maxSize
395 fromString "minOccur" = AttrName_minOccur
396 fromString "maxOccur" = AttrName_maxOccur
397 fromString "numParts" = AttrName_numParts
398 fromString "minNumParts" = AttrName_minNumParts
399 fromString "maxNumParts" = AttrName_maxNumParts
400 fromString "partSize" = AttrName_partSize
401 fromString "minPartSize" = AttrName_minPartSize
402 fromString "maxPartSize" = AttrName_maxPartSize
403 fromString "total" = AttrName_total
404 fromString "injective" = AttrName_injective
405 fromString "surjective" = AttrName_surjective
406 fromString "bijective" = AttrName_bijective
407 fromString "regular" = AttrName_regular
408 fromString "reflexive" = AttrName_reflexive
409 fromString "irreflexive" = AttrName_irreflexive
410 fromString "coreflexive" = AttrName_coreflexive
411 fromString "symmetric" = AttrName_symmetric
412 fromString "antiSymmetric" = AttrName_antiSymmetric
413 fromString "aSymmetric" = AttrName_aSymmetric
414 fromString "transitive" = AttrName_transitive
415 fromString "connex" = AttrName_connex
416 fromString "leftTotal" = AttrName_leftTotal
417 fromString "rightTotal" = AttrName_rightTotal
418 fromString "Euclidean" = AttrName_Euclidean
419 fromString "serial" = AttrName_serial
420 fromString "equivalence" = AttrName_equivalence
421 fromString "partialOrder" = AttrName_partialOrder
422 fromString "linearOrder" = AttrName_linearOrder
423 fromString "weakOrder" = AttrName_weakOrder
424 fromString "preOrder" = AttrName_preOrder
425 fromString s = bug $ "fromString{AttrName}:" <+> pretty s
426
427 binRelNames :: [String]
428 binRelNames = [ "reflexive", "irreflexive", "coreflexive"
429 , "symmetric", "antiSymmetric", "aSymmetric"
430 , "transitive", "total", "leftTotal", "rightTotal", "connex", "Euclidean"
431 , "serial", "equivalence", "weakOrder", "preOrder", "partialOrder", "strictPartialOrder", "linearOrder"
432 ]
433
434
435 --------------------------------------------------------------------------------
436 -- attribute definitions -------------------------------------------------------
437 --------------------------------------------------------------------------------
438
439 data SetAttr a = SetAttr (SizeAttr a)
440 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
441 instance Serialize a => Serialize (SetAttr a)
442 instance Hashable a => Hashable (SetAttr a)
443 instance ToJSON a => ToJSON (SetAttr a) where toJSON = genericToJSON jsonOptions
444 instance FromJSON a => FromJSON (SetAttr a) where parseJSON = genericParseJSON jsonOptions
445 instance Default (SetAttr a) where def = SetAttr def
446 instance Pretty a => Pretty (SetAttr a) where
447 pretty (SetAttr SizeAttr_None) = prEmpty
448 pretty (SetAttr a) = prParens (pretty a)
449
450
451 data SizeAttr a
452 = SizeAttr_None
453 | SizeAttr_Size a
454 | SizeAttr_MinSize a
455 | SizeAttr_MaxSize a
456 | SizeAttr_MinMaxSize a a
457 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
458 instance Serialize a => Serialize (SizeAttr a)
459 instance Hashable a => Hashable (SizeAttr a)
460 instance ToJSON a => ToJSON (SizeAttr a) where toJSON = genericToJSON jsonOptions
461 instance FromJSON a => FromJSON (SizeAttr a) where parseJSON = genericParseJSON jsonOptions
462 instance Default (SizeAttr a) where def = SizeAttr_None
463 instance Pretty a => Pretty (SizeAttr a) where
464 pretty SizeAttr_None = prEmpty
465 pretty (SizeAttr_Size x ) = "size" <+> pretty x
466 pretty (SizeAttr_MinSize x ) = "minSize" <+> pretty x
467 pretty (SizeAttr_MaxSize x ) = "maxSize" <+> pretty x
468 pretty (SizeAttr_MinMaxSize x y) = "minSize" <+> pretty x <> ", maxSize" <+> pretty y
469
470
471 getMaxFrom_SizeAttr :: MonadFailDoc m => SizeAttr a -> m a
472 getMaxFrom_SizeAttr (SizeAttr_Size n) = return n
473 getMaxFrom_SizeAttr (SizeAttr_MaxSize n) = return n
474 getMaxFrom_SizeAttr (SizeAttr_MinMaxSize _ n) = return n
475 getMaxFrom_SizeAttr _ = failDoc "getMaxFrom_SizeAttr"
476
477 intersectSizeAttr :: SizeAttr a -> SizeAttr a -> SizeAttr a
478 intersectSizeAttr SizeAttr_None s = s
479 intersectSizeAttr s@SizeAttr_Size{} _ = s
480 intersectSizeAttr _ s@SizeAttr_Size{} = s
481 intersectSizeAttr s _ = s
482
483 data MSetAttr a = MSetAttr (SizeAttr a) (OccurAttr a)
484 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
485 instance Serialize a => Serialize (MSetAttr a)
486 instance Hashable a => Hashable (MSetAttr a)
487 instance ToJSON a => ToJSON (MSetAttr a) where toJSON = genericToJSON jsonOptions
488 instance FromJSON a => FromJSON (MSetAttr a) where parseJSON = genericParseJSON jsonOptions
489 instance Default (MSetAttr a) where def = MSetAttr def def
490 instance Pretty a => Pretty (MSetAttr a) where
491 pretty (MSetAttr a b) =
492 let inside = filter ((""/=) . show) [ pretty a
493 , pretty b
494 ]
495 in if null inside
496 then prEmpty
497 else prettyList prParens "," inside
498
499
500 data OccurAttr a
501 = OccurAttr_None
502 | OccurAttr_MinOccur a
503 | OccurAttr_MaxOccur a
504 | OccurAttr_MinMaxOccur a a
505 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
506 instance Serialize a => Serialize (OccurAttr a)
507 instance Hashable a => Hashable (OccurAttr a)
508 instance ToJSON a => ToJSON (OccurAttr a) where toJSON = genericToJSON jsonOptions
509 instance FromJSON a => FromJSON (OccurAttr a) where parseJSON = genericParseJSON jsonOptions
510 instance Default (OccurAttr a) where def = OccurAttr_None
511 instance Pretty a => Pretty (OccurAttr a) where
512 pretty OccurAttr_None = prEmpty
513 pretty (OccurAttr_MinOccur x ) = "minOccur" <+> pretty x
514 pretty (OccurAttr_MaxOccur x ) = "maxOccur" <+> pretty x
515 pretty (OccurAttr_MinMaxOccur x y) = "minOccur" <+> pretty x <> ", maxOccur" <+> pretty y
516
517
518 getMaxFrom_OccurAttr :: MonadFailDoc m => OccurAttr a -> m a
519 getMaxFrom_OccurAttr (OccurAttr_MaxOccur n) = return n
520 getMaxFrom_OccurAttr (OccurAttr_MinMaxOccur _ n) = return n
521 getMaxFrom_OccurAttr _ = failDoc "getMaxFrom_OccurAttr"
522
523
524 data FunctionAttr x
525 = FunctionAttr (SizeAttr x) PartialityAttr JectivityAttr
526 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
527 instance Serialize a => Serialize (FunctionAttr a)
528 instance Hashable a => Hashable (FunctionAttr a)
529 instance ToJSON a => ToJSON (FunctionAttr a) where toJSON = genericToJSON jsonOptions
530 instance FromJSON a => FromJSON (FunctionAttr a) where parseJSON = genericParseJSON jsonOptions
531 instance Default (FunctionAttr a) where def = FunctionAttr def def def
532 instance Pretty a => Pretty (FunctionAttr a) where
533 pretty (FunctionAttr a b c) =
534 let inside = filter ((""/=) . show) [pretty a, pretty b, pretty c]
535 in if null inside
536 then prEmpty
537 else prettyList prParens "," inside
538
539
540 data PartialityAttr
541 = PartialityAttr_Partial
542 | PartialityAttr_Total
543 deriving (Eq, Ord, Show, Data, Typeable, Generic)
544 instance Serialize PartialityAttr
545 instance Hashable PartialityAttr
546 instance ToJSON PartialityAttr where toJSON = genericToJSON jsonOptions
547 instance FromJSON PartialityAttr where parseJSON = genericParseJSON jsonOptions
548 instance Default PartialityAttr where def = PartialityAttr_Partial
549 instance Pretty PartialityAttr where
550 pretty PartialityAttr_Partial = prEmpty -- partial is the default
551 pretty PartialityAttr_Total = "total"
552
553
554 data JectivityAttr
555 = JectivityAttr_None
556 | JectivityAttr_Injective
557 | JectivityAttr_Surjective
558 | JectivityAttr_Bijective
559 deriving (Eq, Ord, Show, Data, Typeable, Generic)
560 instance Serialize JectivityAttr
561 instance Hashable JectivityAttr
562 instance ToJSON JectivityAttr where toJSON = genericToJSON jsonOptions
563 instance FromJSON JectivityAttr where parseJSON = genericParseJSON jsonOptions
564 instance Default JectivityAttr where def = JectivityAttr_None
565 instance Pretty JectivityAttr where
566 pretty JectivityAttr_None = prEmpty
567 pretty JectivityAttr_Injective = "injective"
568 pretty JectivityAttr_Surjective = "surjective"
569 pretty JectivityAttr_Bijective = "bijective"
570
571
572 data SequenceAttr x
573 = SequenceAttr (SizeAttr x) JectivityAttr
574 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
575 instance Serialize a => Serialize (SequenceAttr a)
576 instance Hashable a => Hashable (SequenceAttr a)
577 instance ToJSON a => ToJSON (SequenceAttr a) where toJSON = genericToJSON jsonOptions
578 instance FromJSON a => FromJSON (SequenceAttr a) where parseJSON = genericParseJSON jsonOptions
579 instance Default (SequenceAttr a) where def = SequenceAttr def def
580 instance Pretty a => Pretty (SequenceAttr a) where
581 pretty (SequenceAttr a b) =
582 let inside = filter ((""/=) . show) [pretty a, pretty b]
583 in if null inside
584 then prEmpty
585 else prettyList prParens "," inside
586
587
588 data RelationAttr a = RelationAttr (SizeAttr a) BinaryRelationAttrs
589 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
590 instance Serialize a => Serialize (RelationAttr a)
591 instance Hashable a => Hashable (RelationAttr a)
592 instance ToJSON a => ToJSON (RelationAttr a) where toJSON = genericToJSON jsonOptions
593 instance FromJSON a => FromJSON (RelationAttr a) where parseJSON = genericParseJSON jsonOptions
594 instance Default (RelationAttr a) where def = RelationAttr def def
595 instance Pretty a => Pretty (RelationAttr a) where
596 pretty (RelationAttr a b) =
597 let inside = filter ((""/=) . show) [pretty a, pretty b]
598 in if null inside
599 then prEmpty
600 else prettyList prParens "," inside
601
602
603 data BinaryRelationAttrs = BinaryRelationAttrs (S.Set BinaryRelationAttr)
604 deriving (Eq, Ord, Show, Data, Typeable, Generic)
605 instance Serialize BinaryRelationAttrs
606 instance Hashable BinaryRelationAttrs where hashWithSalt salt (BinaryRelationAttrs a) = hashWithSalt salt (S.toList a)
607 instance ToJSON BinaryRelationAttrs where toJSON = genericToJSON jsonOptions
608 instance FromJSON BinaryRelationAttrs where parseJSON = genericParseJSON jsonOptions
609 instance Default BinaryRelationAttrs where def = BinaryRelationAttrs S.empty
610 instance Pretty BinaryRelationAttrs where
611 pretty (BinaryRelationAttrs attrs) = prettyList id "," (S.toList attrs)
612 instance Semigroup BinaryRelationAttrs where
613 (<>) (BinaryRelationAttrs a) (BinaryRelationAttrs b) = BinaryRelationAttrs (S.union a b)
614 instance Monoid BinaryRelationAttrs where
615 mempty = BinaryRelationAttrs def
616
617
618
619 data BinaryRelationAttr
620 = BinRelAttr_Reflexive
621 | BinRelAttr_Irreflexive
622 | BinRelAttr_Coreflexive
623 | BinRelAttr_Symmetric
624 | BinRelAttr_AntiSymmetric
625 | BinRelAttr_ASymmetric
626 | BinRelAttr_Transitive
627 | BinRelAttr_Total
628 | BinRelAttr_LeftTotal
629 | BinRelAttr_RightTotal
630 | BinRelAttr_Connex
631 | BinRelAttr_Euclidean
632 | BinRelAttr_Serial
633 | BinRelAttr_Equivalence
634 | BinRelAttr_PartialOrder
635 | BinRelAttr_LinearOrder
636 | BinRelAttr_WeakOrder
637 | BinRelAttr_PreOrder
638 | BinRelAttr_StrictPartialOrder
639 deriving (Eq, Ord, Show, Data, Typeable, Generic, Bounded, Enum)
640
641 instance Serialize BinaryRelationAttr
642 instance Hashable BinaryRelationAttr
643 instance ToJSON BinaryRelationAttr where toJSON = genericToJSON jsonOptions
644 instance FromJSON BinaryRelationAttr where parseJSON = genericParseJSON jsonOptions
645 instance Pretty BinaryRelationAttr where
646 pretty BinRelAttr_Reflexive = "reflexive"
647 pretty BinRelAttr_Irreflexive = "irreflexive"
648 pretty BinRelAttr_Coreflexive = "coreflexive"
649 pretty BinRelAttr_Symmetric = "symmetric"
650 pretty BinRelAttr_AntiSymmetric = "antiSymmetric"
651 pretty BinRelAttr_ASymmetric = "aSymmetric"
652 pretty BinRelAttr_Transitive = "transitive"
653 pretty BinRelAttr_Total = "total"
654 pretty BinRelAttr_LeftTotal = "leftTotal"
655 pretty BinRelAttr_RightTotal = "rightTotal"
656 pretty BinRelAttr_Connex = "connex"
657 pretty BinRelAttr_Euclidean = "Euclidean"
658 pretty BinRelAttr_Serial = "serial"
659 pretty BinRelAttr_Equivalence = "equivalence"
660 pretty BinRelAttr_PartialOrder = "partialOrder"
661 pretty BinRelAttr_LinearOrder = "linearOrder"
662 pretty BinRelAttr_WeakOrder = "weakOrder"
663 pretty BinRelAttr_PreOrder = "preOrder"
664 pretty BinRelAttr_StrictPartialOrder = "strictPartialOrder"
665
666
667 readBinRel :: MonadFailDoc m => AttrName -> m BinaryRelationAttr
668 readBinRel AttrName_reflexive = return BinRelAttr_Reflexive
669 readBinRel AttrName_irreflexive = return BinRelAttr_Irreflexive
670 readBinRel AttrName_coreflexive = return BinRelAttr_Coreflexive
671 readBinRel AttrName_symmetric = return BinRelAttr_Symmetric
672 readBinRel AttrName_antiSymmetric = return BinRelAttr_AntiSymmetric
673 readBinRel AttrName_aSymmetric = return BinRelAttr_ASymmetric
674 readBinRel AttrName_transitive = return BinRelAttr_Transitive
675 readBinRel AttrName_total = return BinRelAttr_Total
676 readBinRel AttrName_leftTotal = return BinRelAttr_LeftTotal
677 readBinRel AttrName_rightTotal = return BinRelAttr_RightTotal
678 readBinRel AttrName_connex = return BinRelAttr_Connex
679 readBinRel AttrName_Euclidean = return BinRelAttr_Euclidean
680 readBinRel AttrName_serial = return BinRelAttr_Serial
681 readBinRel AttrName_equivalence = return BinRelAttr_Equivalence
682 readBinRel AttrName_partialOrder = return BinRelAttr_PartialOrder
683 readBinRel AttrName_strictPartialOrder = return BinRelAttr_StrictPartialOrder
684 readBinRel AttrName_linearOrder = return BinRelAttr_LinearOrder
685 readBinRel AttrName_weakOrder = return BinRelAttr_WeakOrder
686 readBinRel AttrName_preOrder = return BinRelAttr_PreOrder
687 readBinRel a = failDoc $ "Not a binary relation attribute:" <+> pretty a
688
689 binRelToAttrName :: BinaryRelationAttr -> AttrName
690 binRelToAttrName BinRelAttr_Reflexive = AttrName_reflexive
691 binRelToAttrName BinRelAttr_Irreflexive = AttrName_irreflexive
692 binRelToAttrName BinRelAttr_Coreflexive = AttrName_coreflexive
693 binRelToAttrName BinRelAttr_Symmetric = AttrName_symmetric
694 binRelToAttrName BinRelAttr_AntiSymmetric = AttrName_antiSymmetric
695 binRelToAttrName BinRelAttr_ASymmetric = AttrName_aSymmetric
696 binRelToAttrName BinRelAttr_Transitive = AttrName_transitive
697 binRelToAttrName BinRelAttr_Total = AttrName_total
698 binRelToAttrName BinRelAttr_LeftTotal = AttrName_leftTotal
699 binRelToAttrName BinRelAttr_RightTotal = AttrName_rightTotal
700 binRelToAttrName BinRelAttr_Connex = AttrName_connex
701 binRelToAttrName BinRelAttr_Euclidean = AttrName_Euclidean
702 binRelToAttrName BinRelAttr_Serial = AttrName_serial
703 binRelToAttrName BinRelAttr_Equivalence = AttrName_equivalence
704 binRelToAttrName BinRelAttr_PartialOrder = AttrName_partialOrder
705 binRelToAttrName BinRelAttr_LinearOrder = AttrName_linearOrder
706 binRelToAttrName BinRelAttr_WeakOrder = AttrName_weakOrder
707 binRelToAttrName BinRelAttr_PreOrder = AttrName_preOrder
708 binRelToAttrName BinRelAttr_StrictPartialOrder = AttrName_strictPartialOrder
709
710
711
712
713 data PartitionAttr a = PartitionAttr
714 { partsNum :: SizeAttr a
715 , partsSize :: SizeAttr a
716 , isRegular :: Bool
717 }
718 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
719 instance Serialize a => Serialize (PartitionAttr a)
720 instance Hashable a => Hashable (PartitionAttr a)
721 instance ToJSON a => ToJSON (PartitionAttr a) where toJSON = genericToJSON jsonOptions
722 instance FromJSON a => FromJSON (PartitionAttr a) where parseJSON = genericParseJSON jsonOptions
723 instance Default (PartitionAttr a) where def = PartitionAttr def def False
724 instance Pretty a => Pretty (PartitionAttr a) where
725 pretty (PartitionAttr a b c) =
726 let inside = filter ((""/=) . show) [ prettyNum a
727 , prettySize b
728 , prettyReg c
729 ]
730
731 prettyNum SizeAttr_None = prEmpty
732 prettyNum (SizeAttr_Size x ) = "numParts" <+> pretty x
733 prettyNum (SizeAttr_MinSize x ) = "minNumParts" <+> pretty x
734 prettyNum (SizeAttr_MaxSize x ) = "maxNumParts" <+> pretty x
735 prettyNum (SizeAttr_MinMaxSize x y) = "minNumParts" <+> pretty x <> ", maxNumParts" <+> pretty y
736
737 prettySize SizeAttr_None = prEmpty
738 prettySize (SizeAttr_Size x ) = "partSize" <+> pretty x
739 prettySize (SizeAttr_MinSize x ) = "minPartSize" <+> pretty x
740 prettySize (SizeAttr_MaxSize x ) = "maxPartSize" <+> pretty x
741 prettySize (SizeAttr_MinMaxSize x y) = "minPartSize" <+> pretty x <> ", maxPartSize" <+> pretty y
742
743 prettyReg False = prEmpty
744 prettyReg True = "regular"
745
746 in if null inside
747 then prEmpty
748 else prettyList prParens "," inside
749
750
751 data DomainAttributes a = DomainAttributes [DomainAttribute a]
752 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
753
754 instance Serialize a => Serialize (DomainAttributes a)
755 instance Hashable a => Hashable (DomainAttributes a)
756 instance ToJSON a => ToJSON (DomainAttributes a) where toJSON = genericToJSON jsonOptions
757 instance FromJSON a => FromJSON (DomainAttributes a) where parseJSON = genericParseJSON jsonOptions
758
759 instance Default (DomainAttributes a) where
760 def = DomainAttributes []
761
762
763 data DomainAttribute a
764 = DAName Name
765 | DANameValue Name a
766 | DADotDot
767 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
768
769 instance Serialize a => Serialize (DomainAttribute a)
770 instance Hashable a => Hashable (DomainAttribute a)
771 instance ToJSON a => ToJSON (DomainAttribute a) where toJSON = genericToJSON jsonOptions
772 instance FromJSON a => FromJSON (DomainAttribute a) where parseJSON = genericParseJSON jsonOptions
773
774
775 data Range a
776 = RangeOpen
777 | RangeSingle a
778 | RangeLowerBounded a
779 | RangeUpperBounded a
780 | RangeBounded a a
781 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
782
783 instance Serialize a => Serialize (Range a)
784 instance Hashable a => Hashable (Range a)
785 instance ToJSON a => ToJSON (Range a) where toJSON = genericToJSON jsonOptions
786 instance FromJSON a => FromJSON (Range a) where parseJSON = genericParseJSON jsonOptions
787
788 instance Arbitrary a => Arbitrary (Range a) where
789 arbitrary = oneof
790 [ return RangeOpen
791 , RangeSingle <$> arbitrary
792 , RangeLowerBounded <$> arbitrary
793 , RangeUpperBounded <$> arbitrary
794 , RangeBounded <$> arbitrary <*> arbitrary
795 ]
796
797 rangesInts :: (MonadFailDoc m, ExpressionLike c) => [Range c] -> m [Integer]
798 rangesInts = fmap (sortNub . concat) . mapM rangeInts
799 where
800 rangeInts (RangeSingle x) = return <$> intOut "rangeInts 1" x
801 rangeInts (RangeBounded x y) = do x' <- intOut "rangeInts 2" x
802 y' <- intOut "rangeInts 3" y
803 return [x' .. y']
804 rangeInts _ = failDoc "Infinite range (or not an integer range)"
805
806 expandRanges :: ExpressionLike c => [Range c] -> [Range c]
807 expandRanges [RangeBounded a b] = [RangeBounded a b]
808 expandRanges r =
809 case rangesInts r of
810 Nothing -> r
811 Just [] -> []
812 Just is ->
813 if [ minimum is .. maximum is ] == is
814 then [RangeBounded (fromInt (minimum is)) (fromInt (maximum is))]
815 else map (RangeSingle . fromInt) is
816
817
818 data HasRepresentation
819 = NoRepresentation
820
821 | Set_Occurrence
822 | Set_Explicit
823 | Set_ExplicitVarSizeWithFlags
824 | Set_ExplicitVarSizeWithMarker
825 | Set_ExplicitVarSizeWithDummy
826
827 | MSet_Occurrence
828 | MSet_ExplicitWithFlags
829 | MSet_ExplicitWithRepetition
830
831 | Function_1D
832 | Function_1DPartial
833 | Function_ND
834 | Function_NDPartial
835 | Function_NDPartialDummy
836 | Function_AsRelation HasRepresentation -- carries: representation for the inner relation
837
838 | Sequence_ExplicitBounded
839
840 | Relation_AsMatrix
841 | Relation_AsSet HasRepresentation -- carries: representation for the inner set
842
843 | Partition_AsSet HasRepresentation HasRepresentation -- carries: representations for the inner sets
844 | Partition_Occurrence
845
846 deriving (Eq, Ord, Show, Data, Typeable, Generic)
847
848 instance Serialize HasRepresentation
849 instance Hashable HasRepresentation
850 instance ToJSON HasRepresentation where toJSON = genericToJSON jsonOptions
851 instance FromJSON HasRepresentation where parseJSON = genericParseJSON jsonOptions
852
853 instance Default HasRepresentation where
854 def = NoRepresentation
855
856 representationConstrIndex :: HasRepresentation -> [Text]
857 representationConstrIndex r = oneLevel r : concatMap representationConstrIndex (children r)
858 where
859 oneLevel :: HasRepresentation -> Text
860 oneLevel = stringToText . ("R"++) . show . constrIndex . toConstr
861
862 instance (Pretty r, Pretty a) => Pretty (Domain r a) where
863
864 pretty DomainAny{} = "?"
865
866 pretty DomainBool = "bool"
867
868 pretty (DomainIntE x) = "int" <> prParens (pretty x)
869
870 -- print them like integers even when they are tagged
871 -- pretty (DomainInt (TagEnum nm) _) = pretty nm
872 -- pretty (DomainInt (TagUnnamed nm) _) = pretty nm
873
874 pretty (DomainInt _ []) = "int"
875 pretty (DomainInt _ ranges) = "int" <> prettyList prParens "," ranges
876
877 pretty (DomainEnum name (Just ranges) _) = pretty name <> prettyList prParens "," ranges
878 pretty (DomainEnum name _ _) = pretty name
879
880 pretty (DomainUnnamed name _) = pretty name
881
882 pretty (DomainTuple inners)
883 = (if length inners < 2 then "tuple" else prEmpty)
884 <+> prettyList prParens "," inners
885
886 pretty (DomainRecord xs) = "record" <+> prettyList prBraces ","
887 [ pretty nm <+> ":" <++> pretty d | (nm, d) <- xs ]
888
889 pretty (DomainVariant xs) = "variant" <+> prettyList prBraces ","
890 [ pretty nm <+> ":" <++> pretty d | (nm, d) <- xs ]
891
892 pretty (DomainMatrix index innerNested)
893 = "matrix indexed by" <+> prettyList prBrackets "," indices
894 <+> "of" <++> pretty inner
895 where
896 (indices,inner) = first (index:) $ collect innerNested
897 collect (DomainMatrix i j) = first (i:) $ collect j
898 collect x = ([],x)
899
900 pretty (DomainSet r attrs inner) =
901 "set" <+> prettyAttrs r attrs <+> "of" <++> pretty inner
902
903 pretty (DomainMSet r attrs inner) =
904 "mset" <+> prettyAttrs r attrs <+> "of" <++> pretty inner
905
906 pretty (DomainFunction r attrs innerFrom innerTo) =
907 "function" <+> prettyAttrs r attrs <++> pretty innerFrom <++> "-->" <++> pretty innerTo
908
909 pretty (DomainSequence r attrs inner) =
910 "sequence" <+> prettyAttrs r attrs <+> "of" <++> pretty inner
911
912 pretty (DomainRelation r attrs inners)
913 = "relation" <+> prettyAttrs r attrs <+> "of" <++> prettyList prParens " *" inners
914
915 pretty (DomainPartition r attrs inner)
916 = "partition" <+> prettyAttrs r attrs <+> "from" <++> pretty inner
917
918 pretty d@DomainOp{} = pretty (show d)
919
920 pretty (DomainReference x _) = pretty x
921
922 pretty (DomainMetaVar x) = "&" <> pretty x
923
924
925 prettyAttrs :: (Pretty a, Pretty b) => a -> b -> Doc
926 prettyAttrs a bs =
927 let prettya = pretty a
928 in if show prettya == "()"
929 then pretty bs
930 else prBraces prettya <+> pretty bs
931
932 instance Pretty a => Pretty (DomainAttributes a) where
933 pretty (DomainAttributes []) = prEmpty
934 pretty (DomainAttributes attrs) = prettyList prParens "," attrs
935
936 instance Pretty a => Pretty (DomainAttribute a) where
937 pretty (DAName name) = pretty name
938 pretty (DANameValue name value) = pretty name <+> pretty value
939 pretty DADotDot = ".."
940
941 instance Pretty a => Pretty (Range a) where
942 pretty RangeOpen = ".."
943 pretty (RangeSingle x) = pretty x
944 pretty (RangeLowerBounded x) = pretty x <> ".."
945 pretty (RangeUpperBounded x) = ".." <> pretty x
946 pretty (RangeBounded x y) | show (pretty x) == show (pretty y) = pretty x
947 pretty (RangeBounded x y) = pretty x <> ".." <> pretty y
948
949 instance Pretty HasRepresentation where
950 pretty NoRepresentation = "∅"
951 pretty r = pretty (representationToFullText r)
952
953 textToRepresentation :: Text -> [HasRepresentation] -> Maybe HasRepresentation
954 textToRepresentation t [] | t == "Occurrence" = return Set_Occurrence
955 textToRepresentation t [] | t == "Explicit" = return Set_Explicit
956 textToRepresentation t [] | t == "ExplicitVarSizeWithFlags" = return Set_ExplicitVarSizeWithFlags
957 textToRepresentation t [] | t == "ExplicitVarSizeWithMarker" = return Set_ExplicitVarSizeWithMarker
958 textToRepresentation t [] | t == "ExplicitVarSizeWithDummy" = return Set_ExplicitVarSizeWithDummy
959 textToRepresentation t [] | t == "MOccurrence" = return MSet_Occurrence
960 textToRepresentation t [] | t == "ExplicitWithFlags" = return MSet_ExplicitWithFlags
961 textToRepresentation t [] | t == "ExplicitWithRepetition" = return MSet_ExplicitWithRepetition
962 textToRepresentation t [] | t == "Function1D" = return Function_1D
963 textToRepresentation t [] | t == "Function1DPartial" = return Function_1DPartial
964 textToRepresentation t [] | t == "FunctionND" = return Function_ND
965 textToRepresentation t [] | t == "FunctionNDPartial" = return Function_NDPartial
966 textToRepresentation t [] | t == "FunctionNDPartialDummy" = return Function_NDPartialDummy
967 textToRepresentation t [repr] | t == "FunctionAsRelation" = return (Function_AsRelation repr)
968 textToRepresentation t [] | t == "ExplicitBounded" = return Sequence_ExplicitBounded
969 textToRepresentation t [] | t == "RelationAsMatrix" = return Relation_AsMatrix
970 textToRepresentation t [repr] | t == "RelationAsSet" = return (Relation_AsSet repr)
971 textToRepresentation t [repr1, repr2] | t == "PartitionAsSet" = return (Partition_AsSet repr1 repr2)
972 textToRepresentation t [] | t == "PartitionOccurrence" = return Partition_Occurrence
973 textToRepresentation _ _ = Nothing
974
975 representationToShortText :: HasRepresentation -> Text
976 representationToShortText Set_Occurrence = "Occurrence"
977 representationToShortText Set_Explicit = "Explicit"
978 representationToShortText Set_ExplicitVarSizeWithFlags = "ExplicitVarSizeWithFlags"
979 representationToShortText Set_ExplicitVarSizeWithMarker = "ExplicitVarSizeWithMarker"
980 representationToShortText Set_ExplicitVarSizeWithDummy = "ExplicitVarSizeWithDummy"
981 representationToShortText MSet_Occurrence = "MOccurrence"
982 representationToShortText MSet_ExplicitWithFlags = "ExplicitWithFlags"
983 representationToShortText MSet_ExplicitWithRepetition = "ExplicitWithRepetition"
984 representationToShortText Function_1D = "Function1D"
985 representationToShortText Function_1DPartial = "Function1DPartial"
986 representationToShortText Function_ND = "FunctionND"
987 representationToShortText Function_NDPartial = "FunctionNDPartial"
988 representationToShortText Function_NDPartialDummy = "FunctionNDPartialDummy"
989 representationToShortText Function_AsRelation{} = "FunctionAsRelation"
990 representationToShortText Sequence_ExplicitBounded = "ExplicitBounded"
991 representationToShortText Relation_AsMatrix = "RelationAsMatrix"
992 representationToShortText Relation_AsSet{} = "RelationAsSet"
993 representationToShortText Partition_AsSet{} = "PartitionAsSet"
994 representationToShortText Partition_Occurrence = "PartitionOccurrence"
995 representationToShortText r = bug ("representationToShortText:" <+> pretty (show r))
996
997 representationToFullText :: HasRepresentation -> Text
998 representationToFullText (Function_AsRelation repr) = mconcat [ "FunctionAsRelation"
999 , "["
1000 , representationToFullText repr
1001 , "]"
1002 ]
1003 representationToFullText (Relation_AsSet repr) = mconcat [ "RelationAsSet"
1004 , "["
1005 , representationToFullText repr
1006 , "]"
1007 ]
1008 representationToFullText (Partition_AsSet repr1 repr2) = mconcat [ "PartitionAsSet"
1009 , "["
1010 , representationToFullText repr1
1011 , ","
1012 , representationToFullText repr2
1013 , "]"
1014 ]
1015 representationToFullText r = representationToShortText r
1016
1017
1018 normaliseDomain :: (Ord c, ExpressionLike c) => (c -> c) -> Domain r c -> Domain r c
1019 normaliseDomain _norm DomainBool = DomainBool
1020 normaliseDomain norm (DomainInt t rs ) = DomainInt t $ sort $ map (normaliseRange norm) (expandRanges rs)
1021 normaliseDomain _norm (DomainEnum n Nothing mp) = DomainEnum n Nothing mp
1022 normaliseDomain _norm (DomainEnum n (Just rs) mp) = DomainEnum n (Just $ sort rs) mp
1023 normaliseDomain norm (DomainUnnamed n x ) = DomainUnnamed n (norm x)
1024 normaliseDomain norm (DomainRecord doms ) = DomainRecord [ (n, normaliseDomain norm d)
1025 | (n, d) <- doms ]
1026 normaliseDomain norm (DomainVariant doms ) = DomainVariant [ (n, normaliseDomain norm d)
1027 | (n, d) <- doms ]
1028 normaliseDomain norm (DomainTuple doms ) = DomainTuple $ map (normaliseDomain norm) doms
1029 normaliseDomain norm (DomainMatrix dom1 dom2) = DomainMatrix (normaliseDomain norm dom1)
1030 (normaliseDomain norm dom2)
1031 normaliseDomain norm (DomainSet r attr dom ) = DomainSet r (fmap norm attr)
1032 (normaliseDomain norm dom)
1033 normaliseDomain norm (DomainMSet r attr dom ) = DomainMSet r (fmap norm attr)
1034 (normaliseDomain norm dom)
1035 normaliseDomain norm (DomainFunction r attr dom1 dom2) = DomainFunction r (fmap norm attr)
1036 (normaliseDomain norm dom1)
1037 (normaliseDomain norm dom2)
1038 normaliseDomain norm (DomainSequence r attr dom ) = DomainSequence r (fmap norm attr)
1039 (normaliseDomain norm dom)
1040 normaliseDomain norm (DomainRelation r attr doms ) = DomainRelation r (fmap norm attr)
1041 (map (normaliseDomain norm) doms)
1042 normaliseDomain norm (DomainPartition r attr dom ) = DomainPartition r (fmap norm attr)
1043 (normaliseDomain norm dom)
1044 normaliseDomain _norm d = d
1045
1046 normaliseRange :: (c -> c) -> Range c -> Range c
1047 normaliseRange _norm RangeOpen = RangeOpen
1048 normaliseRange norm (RangeSingle x) = RangeBounded (norm x) (norm x)
1049 normaliseRange norm (RangeLowerBounded x) = RangeLowerBounded (norm x)
1050 normaliseRange norm (RangeUpperBounded x) = RangeUpperBounded (norm x)
1051 normaliseRange norm (RangeBounded x y) = RangeBounded (norm x) (norm y)
1052
1053 innerDomainOf :: (MonadFailDoc m, Show x) => Domain () x -> m (Domain () x)
1054 innerDomainOf (DomainMatrix _ t) = return t
1055 innerDomainOf (DomainSet _ _ t) = return t
1056 innerDomainOf (DomainMSet _ _ t) = return t
1057 innerDomainOf (DomainFunction _ _ a b) = return (DomainTuple [a,b])
1058 innerDomainOf (DomainRelation _ _ ts) = return (DomainTuple ts)
1059 innerDomainOf (DomainPartition _ _ t) = return (DomainSet () def t)
1060 innerDomainOf t = failDoc ("innerDomainOf:" <+> pretty (show t))
1061
1062 singletonDomainInt :: (Eq x, CanBeAnAlias x) => Domain r x -> Maybe x
1063 singletonDomainInt (DomainInt _ [RangeSingle a]) = Just a
1064 singletonDomainInt (DomainInt _ [RangeBounded a b]) =
1065 let
1066 followAlias (isAlias -> Just x) = followAlias x
1067 followAlias x = x
1068 in
1069 if followAlias a == followAlias b
1070 then Just a
1071 else Nothing
1072 singletonDomainInt _ = Nothing
1073
1074 matrixNumDimsD :: Domain r x -> Int
1075 matrixNumDimsD (DomainMatrix _ t) = 1 + matrixNumDimsD t
1076 matrixNumDimsD _ = 0