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) = 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 (DomainMatrix index inner) = domainCanIndexMatrix index && domainCanIndexMatrix inner
302 domainCanIndexMatrix _ = False
303
304 expandDomainReference :: Data r => Data x => Domain r x -> Domain r x
305 expandDomainReference (DomainReference _ (Just d)) = expandDomainReference d
306 expandDomainReference d = descend expandDomainReference d
307
308
309 --------------------------------------------------------------------------------
310 -- attribute-as-constraint handling --------------------------------------------
311 --------------------------------------------------------------------------------
312
313 data AttrName
314 = AttrName_size
315 | AttrName_minSize
316 | AttrName_maxSize
317 | AttrName_minOccur
318 | AttrName_maxOccur
319 | AttrName_numParts
320 | AttrName_minNumParts
321 | AttrName_maxNumParts
322 | AttrName_partSize
323 | AttrName_minPartSize
324 | AttrName_maxPartSize
325 | AttrName_total
326 | AttrName_injective
327 | AttrName_surjective
328 | AttrName_bijective
329 | AttrName_regular
330 -- bin rel ones
331 | AttrName_reflexive
332 | AttrName_irreflexive
333 | AttrName_coreflexive
334 | AttrName_symmetric
335 | AttrName_antiSymmetric
336 | AttrName_aSymmetric
337 | AttrName_transitive
338 | AttrName_leftTotal
339 | AttrName_rightTotal
340 | AttrName_connex
341 | AttrName_Euclidean
342 | AttrName_serial
343 | AttrName_equivalence
344 | AttrName_partialOrder
345 | AttrName_linearOrder
346 | AttrName_weakOrder
347 | AttrName_preOrder
348 | AttrName_strictPartialOrder
349 deriving (Eq, Ord, Show, Data, Typeable, Generic)
350
351 instance Serialize AttrName
352 instance Hashable AttrName
353 instance ToJSON AttrName where toJSON = genericToJSON jsonOptions
354 instance FromJSON AttrName where parseJSON = genericParseJSON jsonOptions
355
356 instance Pretty AttrName where
357 pretty AttrName_size = "size"
358 pretty AttrName_minSize = "minSize"
359 pretty AttrName_maxSize = "maxSize"
360 pretty AttrName_minOccur = "minOccur"
361 pretty AttrName_maxOccur = "maxOccur"
362 pretty AttrName_numParts = "numParts"
363 pretty AttrName_minNumParts = "minNumParts"
364 pretty AttrName_maxNumParts = "maxNumParts"
365 pretty AttrName_partSize = "partSize"
366 pretty AttrName_minPartSize = "minPartSize"
367 pretty AttrName_maxPartSize = "maxPartSize"
368 pretty AttrName_total = "total"
369 pretty AttrName_injective = "injective"
370 pretty AttrName_surjective = "surjective"
371 pretty AttrName_bijective = "bijective"
372 pretty AttrName_regular = "regular"
373 pretty AttrName_reflexive = "reflexive"
374 pretty AttrName_irreflexive = "irreflexive"
375 pretty AttrName_coreflexive = "coreflexive"
376 pretty AttrName_symmetric = "symmetric"
377 pretty AttrName_antiSymmetric = "antiSymmetric"
378 pretty AttrName_aSymmetric = "aSymmetric"
379 pretty AttrName_transitive = "transitive"
380 pretty AttrName_leftTotal = "leftTotal"
381 pretty AttrName_rightTotal = "rightTotal"
382 pretty AttrName_connex = "connex"
383 pretty AttrName_Euclidean = "Euclidean"
384 pretty AttrName_serial = "serial"
385 pretty AttrName_equivalence = "equivalence"
386 pretty AttrName_partialOrder = "partialOrder"
387 pretty AttrName_linearOrder = "linearOrder"
388 pretty AttrName_weakOrder = "weakOrder"
389 pretty AttrName_preOrder = "preOrder"
390 pretty AttrName_strictPartialOrder = "strictPartialOrder"
391
392 instance IsString AttrName where
393 fromString "size" = AttrName_size
394 fromString "minSize" = AttrName_minSize
395 fromString "maxSize" = AttrName_maxSize
396 fromString "minOccur" = AttrName_minOccur
397 fromString "maxOccur" = AttrName_maxOccur
398 fromString "numParts" = AttrName_numParts
399 fromString "minNumParts" = AttrName_minNumParts
400 fromString "maxNumParts" = AttrName_maxNumParts
401 fromString "partSize" = AttrName_partSize
402 fromString "minPartSize" = AttrName_minPartSize
403 fromString "maxPartSize" = AttrName_maxPartSize
404 fromString "total" = AttrName_total
405 fromString "injective" = AttrName_injective
406 fromString "surjective" = AttrName_surjective
407 fromString "bijective" = AttrName_bijective
408 fromString "regular" = AttrName_regular
409 fromString "reflexive" = AttrName_reflexive
410 fromString "irreflexive" = AttrName_irreflexive
411 fromString "coreflexive" = AttrName_coreflexive
412 fromString "symmetric" = AttrName_symmetric
413 fromString "antiSymmetric" = AttrName_antiSymmetric
414 fromString "aSymmetric" = AttrName_aSymmetric
415 fromString "transitive" = AttrName_transitive
416 fromString "connex" = AttrName_connex
417 fromString "leftTotal" = AttrName_leftTotal
418 fromString "rightTotal" = AttrName_rightTotal
419 fromString "Euclidean" = AttrName_Euclidean
420 fromString "serial" = AttrName_serial
421 fromString "equivalence" = AttrName_equivalence
422 fromString "partialOrder" = AttrName_partialOrder
423 fromString "linearOrder" = AttrName_linearOrder
424 fromString "weakOrder" = AttrName_weakOrder
425 fromString "preOrder" = AttrName_preOrder
426 fromString s = bug $ "fromString{AttrName}:" <+> pretty s
427
428 binRelNames :: [String]
429 binRelNames = [ "reflexive", "irreflexive", "coreflexive"
430 , "symmetric", "antiSymmetric", "aSymmetric"
431 , "transitive", "total", "leftTotal", "rightTotal", "connex", "Euclidean"
432 , "serial", "equivalence", "weakOrder", "preOrder", "partialOrder", "strictPartialOrder", "linearOrder"
433 ]
434
435
436 --------------------------------------------------------------------------------
437 -- attribute definitions -------------------------------------------------------
438 --------------------------------------------------------------------------------
439
440 data SetAttr a = SetAttr (SizeAttr a)
441 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
442 instance Serialize a => Serialize (SetAttr a)
443 instance Hashable a => Hashable (SetAttr a)
444 instance ToJSON a => ToJSON (SetAttr a) where toJSON = genericToJSON jsonOptions
445 instance FromJSON a => FromJSON (SetAttr a) where parseJSON = genericParseJSON jsonOptions
446 instance Default (SetAttr a) where def = SetAttr def
447 instance Pretty a => Pretty (SetAttr a) where
448 pretty (SetAttr SizeAttr_None) = prEmpty
449 pretty (SetAttr a) = prParens (pretty a)
450
451
452 data SizeAttr a
453 = SizeAttr_None
454 | SizeAttr_Size a
455 | SizeAttr_MinSize a
456 | SizeAttr_MaxSize a
457 | SizeAttr_MinMaxSize a a
458 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
459 instance Serialize a => Serialize (SizeAttr a)
460 instance Hashable a => Hashable (SizeAttr a)
461 instance ToJSON a => ToJSON (SizeAttr a) where toJSON = genericToJSON jsonOptions
462 instance FromJSON a => FromJSON (SizeAttr a) where parseJSON = genericParseJSON jsonOptions
463 instance Default (SizeAttr a) where def = SizeAttr_None
464 instance Pretty a => Pretty (SizeAttr a) where
465 pretty SizeAttr_None = prEmpty
466 pretty (SizeAttr_Size x ) = "size" <+> pretty x
467 pretty (SizeAttr_MinSize x ) = "minSize" <+> pretty x
468 pretty (SizeAttr_MaxSize x ) = "maxSize" <+> pretty x
469 pretty (SizeAttr_MinMaxSize x y) = "minSize" <+> pretty x <> ", maxSize" <+> pretty y
470
471
472 getMaxFrom_SizeAttr :: MonadFailDoc m => SizeAttr a -> m a
473 getMaxFrom_SizeAttr (SizeAttr_Size n) = return n
474 getMaxFrom_SizeAttr (SizeAttr_MaxSize n) = return n
475 getMaxFrom_SizeAttr (SizeAttr_MinMaxSize _ n) = return n
476 getMaxFrom_SizeAttr _ = failDoc "getMaxFrom_SizeAttr"
477
478 intersectSizeAttr :: SizeAttr a -> SizeAttr a -> SizeAttr a
479 intersectSizeAttr SizeAttr_None s = s
480 intersectSizeAttr s@SizeAttr_Size{} _ = s
481 intersectSizeAttr _ s@SizeAttr_Size{} = s
482 intersectSizeAttr s _ = s
483
484 data MSetAttr a = MSetAttr (SizeAttr a) (OccurAttr a)
485 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
486 instance Serialize a => Serialize (MSetAttr a)
487 instance Hashable a => Hashable (MSetAttr a)
488 instance ToJSON a => ToJSON (MSetAttr a) where toJSON = genericToJSON jsonOptions
489 instance FromJSON a => FromJSON (MSetAttr a) where parseJSON = genericParseJSON jsonOptions
490 instance Default (MSetAttr a) where def = MSetAttr def def
491 instance Pretty a => Pretty (MSetAttr a) where
492 pretty (MSetAttr a b) =
493 let inside = filter ((""/=) . show) [ pretty a
494 , pretty b
495 ]
496 in if null inside
497 then prEmpty
498 else prettyList prParens "," inside
499
500
501 data OccurAttr a
502 = OccurAttr_None
503 | OccurAttr_MinOccur a
504 | OccurAttr_MaxOccur a
505 | OccurAttr_MinMaxOccur a a
506 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
507 instance Serialize a => Serialize (OccurAttr a)
508 instance Hashable a => Hashable (OccurAttr a)
509 instance ToJSON a => ToJSON (OccurAttr a) where toJSON = genericToJSON jsonOptions
510 instance FromJSON a => FromJSON (OccurAttr a) where parseJSON = genericParseJSON jsonOptions
511 instance Default (OccurAttr a) where def = OccurAttr_None
512 instance Pretty a => Pretty (OccurAttr a) where
513 pretty OccurAttr_None = prEmpty
514 pretty (OccurAttr_MinOccur x ) = "minOccur" <+> pretty x
515 pretty (OccurAttr_MaxOccur x ) = "maxOccur" <+> pretty x
516 pretty (OccurAttr_MinMaxOccur x y) = "minOccur" <+> pretty x <> ", maxOccur" <+> pretty y
517
518
519 getMaxFrom_OccurAttr :: MonadFailDoc m => OccurAttr a -> m a
520 getMaxFrom_OccurAttr (OccurAttr_MaxOccur n) = return n
521 getMaxFrom_OccurAttr (OccurAttr_MinMaxOccur _ n) = return n
522 getMaxFrom_OccurAttr _ = failDoc "getMaxFrom_OccurAttr"
523
524
525 data FunctionAttr x
526 = FunctionAttr (SizeAttr x) PartialityAttr JectivityAttr
527 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
528 instance Serialize a => Serialize (FunctionAttr a)
529 instance Hashable a => Hashable (FunctionAttr a)
530 instance ToJSON a => ToJSON (FunctionAttr a) where toJSON = genericToJSON jsonOptions
531 instance FromJSON a => FromJSON (FunctionAttr a) where parseJSON = genericParseJSON jsonOptions
532 instance Default (FunctionAttr a) where def = FunctionAttr def def def
533 instance Pretty a => Pretty (FunctionAttr a) where
534 pretty (FunctionAttr a b c) =
535 let inside = filter ((""/=) . show) [pretty a, pretty b, pretty c]
536 in if null inside
537 then prEmpty
538 else prettyList prParens "," inside
539
540
541 data PartialityAttr
542 = PartialityAttr_Partial
543 | PartialityAttr_Total
544 deriving (Eq, Ord, Show, Data, Typeable, Generic)
545 instance Serialize PartialityAttr
546 instance Hashable PartialityAttr
547 instance ToJSON PartialityAttr where toJSON = genericToJSON jsonOptions
548 instance FromJSON PartialityAttr where parseJSON = genericParseJSON jsonOptions
549 instance Default PartialityAttr where def = PartialityAttr_Partial
550 instance Pretty PartialityAttr where
551 pretty PartialityAttr_Partial = prEmpty -- partial is the default
552 pretty PartialityAttr_Total = "total"
553
554
555 data JectivityAttr
556 = JectivityAttr_None
557 | JectivityAttr_Injective
558 | JectivityAttr_Surjective
559 | JectivityAttr_Bijective
560 deriving (Eq, Ord, Show, Data, Typeable, Generic)
561 instance Serialize JectivityAttr
562 instance Hashable JectivityAttr
563 instance ToJSON JectivityAttr where toJSON = genericToJSON jsonOptions
564 instance FromJSON JectivityAttr where parseJSON = genericParseJSON jsonOptions
565 instance Default JectivityAttr where def = JectivityAttr_None
566 instance Pretty JectivityAttr where
567 pretty JectivityAttr_None = prEmpty
568 pretty JectivityAttr_Injective = "injective"
569 pretty JectivityAttr_Surjective = "surjective"
570 pretty JectivityAttr_Bijective = "bijective"
571
572
573 data SequenceAttr x
574 = SequenceAttr (SizeAttr x) JectivityAttr
575 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
576 instance Serialize a => Serialize (SequenceAttr a)
577 instance Hashable a => Hashable (SequenceAttr a)
578 instance ToJSON a => ToJSON (SequenceAttr a) where toJSON = genericToJSON jsonOptions
579 instance FromJSON a => FromJSON (SequenceAttr a) where parseJSON = genericParseJSON jsonOptions
580 instance Default (SequenceAttr a) where def = SequenceAttr def def
581 instance Pretty a => Pretty (SequenceAttr a) where
582 pretty (SequenceAttr a b) =
583 let inside = filter ((""/=) . show) [pretty a, pretty b]
584 in if null inside
585 then prEmpty
586 else prettyList prParens "," inside
587
588
589 data RelationAttr a = RelationAttr (SizeAttr a) BinaryRelationAttrs
590 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
591 instance Serialize a => Serialize (RelationAttr a)
592 instance Hashable a => Hashable (RelationAttr a)
593 instance ToJSON a => ToJSON (RelationAttr a) where toJSON = genericToJSON jsonOptions
594 instance FromJSON a => FromJSON (RelationAttr a) where parseJSON = genericParseJSON jsonOptions
595 instance Default (RelationAttr a) where def = RelationAttr def def
596 instance Pretty a => Pretty (RelationAttr a) where
597 pretty (RelationAttr a b) =
598 let inside = filter ((""/=) . show) [pretty a, pretty b]
599 in if null inside
600 then prEmpty
601 else prettyList prParens "," inside
602
603
604 data BinaryRelationAttrs = BinaryRelationAttrs (S.Set BinaryRelationAttr)
605 deriving (Eq, Ord, Show, Data, Typeable, Generic)
606 instance Serialize BinaryRelationAttrs
607 instance Hashable BinaryRelationAttrs where hashWithSalt salt (BinaryRelationAttrs a) = hashWithSalt salt (S.toList a)
608 instance ToJSON BinaryRelationAttrs where toJSON = genericToJSON jsonOptions
609 instance FromJSON BinaryRelationAttrs where parseJSON = genericParseJSON jsonOptions
610 instance Default BinaryRelationAttrs where def = BinaryRelationAttrs S.empty
611 instance Pretty BinaryRelationAttrs where
612 pretty (BinaryRelationAttrs attrs) = prettyList id "," (S.toList attrs)
613 instance Semigroup BinaryRelationAttrs where
614 (<>) (BinaryRelationAttrs a) (BinaryRelationAttrs b) = BinaryRelationAttrs (S.union a b)
615 instance Monoid BinaryRelationAttrs where
616 mempty = BinaryRelationAttrs def
617
618
619
620 data BinaryRelationAttr
621 = BinRelAttr_Reflexive
622 | BinRelAttr_Irreflexive
623 | BinRelAttr_Coreflexive
624 | BinRelAttr_Symmetric
625 | BinRelAttr_AntiSymmetric
626 | BinRelAttr_ASymmetric
627 | BinRelAttr_Transitive
628 | BinRelAttr_Total
629 | BinRelAttr_LeftTotal
630 | BinRelAttr_RightTotal
631 | BinRelAttr_Connex
632 | BinRelAttr_Euclidean
633 | BinRelAttr_Serial
634 | BinRelAttr_Equivalence
635 | BinRelAttr_PartialOrder
636 | BinRelAttr_LinearOrder
637 | BinRelAttr_WeakOrder
638 | BinRelAttr_PreOrder
639 | BinRelAttr_StrictPartialOrder
640 deriving (Eq, Ord, Show, Data, Typeable, Generic, Bounded, Enum)
641
642 instance Serialize BinaryRelationAttr
643 instance Hashable BinaryRelationAttr
644 instance ToJSON BinaryRelationAttr where toJSON = genericToJSON jsonOptions
645 instance FromJSON BinaryRelationAttr where parseJSON = genericParseJSON jsonOptions
646 instance Pretty BinaryRelationAttr where
647 pretty BinRelAttr_Reflexive = "reflexive"
648 pretty BinRelAttr_Irreflexive = "irreflexive"
649 pretty BinRelAttr_Coreflexive = "coreflexive"
650 pretty BinRelAttr_Symmetric = "symmetric"
651 pretty BinRelAttr_AntiSymmetric = "antiSymmetric"
652 pretty BinRelAttr_ASymmetric = "aSymmetric"
653 pretty BinRelAttr_Transitive = "transitive"
654 pretty BinRelAttr_Total = "total"
655 pretty BinRelAttr_LeftTotal = "leftTotal"
656 pretty BinRelAttr_RightTotal = "rightTotal"
657 pretty BinRelAttr_Connex = "connex"
658 pretty BinRelAttr_Euclidean = "Euclidean"
659 pretty BinRelAttr_Serial = "serial"
660 pretty BinRelAttr_Equivalence = "equivalence"
661 pretty BinRelAttr_PartialOrder = "partialOrder"
662 pretty BinRelAttr_LinearOrder = "linearOrder"
663 pretty BinRelAttr_WeakOrder = "weakOrder"
664 pretty BinRelAttr_PreOrder = "preOrder"
665 pretty BinRelAttr_StrictPartialOrder = "strictPartialOrder"
666
667
668 readBinRel :: MonadFailDoc m => AttrName -> m BinaryRelationAttr
669 readBinRel AttrName_reflexive = return BinRelAttr_Reflexive
670 readBinRel AttrName_irreflexive = return BinRelAttr_Irreflexive
671 readBinRel AttrName_coreflexive = return BinRelAttr_Coreflexive
672 readBinRel AttrName_symmetric = return BinRelAttr_Symmetric
673 readBinRel AttrName_antiSymmetric = return BinRelAttr_AntiSymmetric
674 readBinRel AttrName_aSymmetric = return BinRelAttr_ASymmetric
675 readBinRel AttrName_transitive = return BinRelAttr_Transitive
676 readBinRel AttrName_total = return BinRelAttr_Total
677 readBinRel AttrName_leftTotal = return BinRelAttr_LeftTotal
678 readBinRel AttrName_rightTotal = return BinRelAttr_RightTotal
679 readBinRel AttrName_connex = return BinRelAttr_Connex
680 readBinRel AttrName_Euclidean = return BinRelAttr_Euclidean
681 readBinRel AttrName_serial = return BinRelAttr_Serial
682 readBinRel AttrName_equivalence = return BinRelAttr_Equivalence
683 readBinRel AttrName_partialOrder = return BinRelAttr_PartialOrder
684 readBinRel AttrName_strictPartialOrder = return BinRelAttr_StrictPartialOrder
685 readBinRel AttrName_linearOrder = return BinRelAttr_LinearOrder
686 readBinRel AttrName_weakOrder = return BinRelAttr_WeakOrder
687 readBinRel AttrName_preOrder = return BinRelAttr_PreOrder
688 readBinRel a = failDoc $ "Not a binary relation attribute:" <+> pretty a
689
690 binRelToAttrName :: BinaryRelationAttr -> AttrName
691 binRelToAttrName BinRelAttr_Reflexive = AttrName_reflexive
692 binRelToAttrName BinRelAttr_Irreflexive = AttrName_irreflexive
693 binRelToAttrName BinRelAttr_Coreflexive = AttrName_coreflexive
694 binRelToAttrName BinRelAttr_Symmetric = AttrName_symmetric
695 binRelToAttrName BinRelAttr_AntiSymmetric = AttrName_antiSymmetric
696 binRelToAttrName BinRelAttr_ASymmetric = AttrName_aSymmetric
697 binRelToAttrName BinRelAttr_Transitive = AttrName_transitive
698 binRelToAttrName BinRelAttr_Total = AttrName_total
699 binRelToAttrName BinRelAttr_LeftTotal = AttrName_leftTotal
700 binRelToAttrName BinRelAttr_RightTotal = AttrName_rightTotal
701 binRelToAttrName BinRelAttr_Connex = AttrName_connex
702 binRelToAttrName BinRelAttr_Euclidean = AttrName_Euclidean
703 binRelToAttrName BinRelAttr_Serial = AttrName_serial
704 binRelToAttrName BinRelAttr_Equivalence = AttrName_equivalence
705 binRelToAttrName BinRelAttr_PartialOrder = AttrName_partialOrder
706 binRelToAttrName BinRelAttr_LinearOrder = AttrName_linearOrder
707 binRelToAttrName BinRelAttr_WeakOrder = AttrName_weakOrder
708 binRelToAttrName BinRelAttr_PreOrder = AttrName_preOrder
709 binRelToAttrName BinRelAttr_StrictPartialOrder = AttrName_strictPartialOrder
710
711
712
713
714 data PartitionAttr a = PartitionAttr
715 { partsNum :: SizeAttr a
716 , partsSize :: SizeAttr a
717 , isRegular :: Bool
718 }
719 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
720 instance Serialize a => Serialize (PartitionAttr a)
721 instance Hashable a => Hashable (PartitionAttr a)
722 instance ToJSON a => ToJSON (PartitionAttr a) where toJSON = genericToJSON jsonOptions
723 instance FromJSON a => FromJSON (PartitionAttr a) where parseJSON = genericParseJSON jsonOptions
724 instance Default (PartitionAttr a) where def = PartitionAttr def def False
725 instance Pretty a => Pretty (PartitionAttr a) where
726 pretty (PartitionAttr a b c) =
727 let inside = filter ((""/=) . show) [ prettyNum a
728 , prettySize b
729 , prettyReg c
730 ]
731
732 prettyNum SizeAttr_None = prEmpty
733 prettyNum (SizeAttr_Size x ) = "numParts" <+> pretty x
734 prettyNum (SizeAttr_MinSize x ) = "minNumParts" <+> pretty x
735 prettyNum (SizeAttr_MaxSize x ) = "maxNumParts" <+> pretty x
736 prettyNum (SizeAttr_MinMaxSize x y) = "minNumParts" <+> pretty x <> ", maxNumParts" <+> pretty y
737
738 prettySize SizeAttr_None = prEmpty
739 prettySize (SizeAttr_Size x ) = "partSize" <+> pretty x
740 prettySize (SizeAttr_MinSize x ) = "minPartSize" <+> pretty x
741 prettySize (SizeAttr_MaxSize x ) = "maxPartSize" <+> pretty x
742 prettySize (SizeAttr_MinMaxSize x y) = "minPartSize" <+> pretty x <> ", maxPartSize" <+> pretty y
743
744 prettyReg False = prEmpty
745 prettyReg True = "regular"
746
747 in if null inside
748 then prEmpty
749 else prettyList prParens "," inside
750
751
752 data DomainAttributes a = DomainAttributes [DomainAttribute a]
753 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
754
755 instance Serialize a => Serialize (DomainAttributes a)
756 instance Hashable a => Hashable (DomainAttributes a)
757 instance ToJSON a => ToJSON (DomainAttributes a) where toJSON = genericToJSON jsonOptions
758 instance FromJSON a => FromJSON (DomainAttributes a) where parseJSON = genericParseJSON jsonOptions
759
760 instance Default (DomainAttributes a) where
761 def = DomainAttributes []
762
763
764 data DomainAttribute a
765 = DAName Name
766 | DANameValue Name a
767 | DADotDot
768 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
769
770 instance Serialize a => Serialize (DomainAttribute a)
771 instance Hashable a => Hashable (DomainAttribute a)
772 instance ToJSON a => ToJSON (DomainAttribute a) where toJSON = genericToJSON jsonOptions
773 instance FromJSON a => FromJSON (DomainAttribute a) where parseJSON = genericParseJSON jsonOptions
774
775
776 data Range a
777 = RangeOpen
778 | RangeSingle a
779 | RangeLowerBounded a
780 | RangeUpperBounded a
781 | RangeBounded a a
782 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
783
784 instance Serialize a => Serialize (Range a)
785 instance Hashable a => Hashable (Range a)
786 instance ToJSON a => ToJSON (Range a) where toJSON = genericToJSON jsonOptions
787 instance FromJSON a => FromJSON (Range a) where parseJSON = genericParseJSON jsonOptions
788
789 instance Arbitrary a => Arbitrary (Range a) where
790 arbitrary = oneof
791 [ return RangeOpen
792 , RangeSingle <$> arbitrary
793 , RangeLowerBounded <$> arbitrary
794 , RangeUpperBounded <$> arbitrary
795 , RangeBounded <$> arbitrary <*> arbitrary
796 ]
797
798 rangesInts :: (MonadFailDoc m, ExpressionLike c) => [Range c] -> m [Integer]
799 rangesInts = fmap (sortNub . concat) . mapM rangeInts
800 where
801 rangeInts (RangeSingle x) = return <$> intOut "rangeInts 1" x
802 rangeInts (RangeBounded x y) = do x' <- intOut "rangeInts 2" x
803 y' <- intOut "rangeInts 3" y
804 return [x' .. y']
805 rangeInts _ = failDoc "Infinite range (or not an integer range)"
806
807 expandRanges :: ExpressionLike c => [Range c] -> [Range c]
808 expandRanges [RangeBounded a b] = [RangeBounded a b]
809 expandRanges r =
810 case rangesInts r of
811 Nothing -> r
812 Just [] -> []
813 Just is ->
814 if [ minimum is .. maximum is ] == is
815 then [RangeBounded (fromInt (minimum is)) (fromInt (maximum is))]
816 else map (RangeSingle . fromInt) is
817
818
819 data HasRepresentation
820 = NoRepresentation
821
822 | Set_Occurrence
823 | Set_Explicit
824 | Set_ExplicitVarSizeWithFlags
825 | Set_ExplicitVarSizeWithMarker
826 | Set_ExplicitVarSizeWithDummy
827
828 | MSet_Occurrence
829 | MSet_ExplicitWithFlags
830 | MSet_ExplicitWithRepetition
831
832 | Function_1D
833 | Function_1DPartial
834 | Function_ND
835 | Function_NDPartial
836 | Function_NDPartialDummy
837 | Function_AsRelation HasRepresentation -- carries: representation for the inner relation
838
839 | Sequence_ExplicitBounded
840
841 | Relation_AsMatrix
842 | Relation_AsSet HasRepresentation -- carries: representation for the inner set
843
844 | Partition_AsSet HasRepresentation HasRepresentation -- carries: representations for the inner sets
845 | Partition_Occurrence
846
847 deriving (Eq, Ord, Show, Data, Typeable, Generic)
848
849 instance Serialize HasRepresentation
850 instance Hashable HasRepresentation
851 instance ToJSON HasRepresentation where toJSON = genericToJSON jsonOptions
852 instance FromJSON HasRepresentation where parseJSON = genericParseJSON jsonOptions
853
854 instance Default HasRepresentation where
855 def = NoRepresentation
856
857 representationConstrIndex :: HasRepresentation -> [Text]
858 representationConstrIndex r = oneLevel r : concatMap representationConstrIndex (children r)
859 where
860 oneLevel :: HasRepresentation -> Text
861 oneLevel = stringToText . ("R"++) . show . constrIndex . toConstr
862
863 instance (Pretty r, Pretty a) => Pretty (Domain r a) where
864
865 pretty DomainAny{} = "?"
866
867 pretty DomainBool = "bool"
868
869 pretty (DomainIntE x) = "int" <> prParens (pretty x)
870
871 -- print them like integers even when they are tagged
872 -- pretty (DomainInt (TagEnum nm) _) = pretty nm
873 -- pretty (DomainInt (TagUnnamed nm) _) = pretty nm
874
875 pretty (DomainInt _ []) = "int"
876 pretty (DomainInt _ ranges) = "int" <> prettyList prParens "," ranges
877
878 pretty (DomainEnum name (Just ranges) _) = pretty name <> prettyList prParens "," ranges
879 pretty (DomainEnum name _ _) = pretty name
880
881 pretty (DomainUnnamed name _) = pretty name
882
883 pretty (DomainTuple inners)
884 = (if length inners < 2 then "tuple" else prEmpty)
885 <+> prettyList prParens "," inners
886
887 pretty (DomainRecord xs) = "record" <+> prettyList prBraces ","
888 [ pretty nm <+> ":" <++> pretty d | (nm, d) <- xs ]
889
890 pretty (DomainVariant xs) = "variant" <+> prettyList prBraces ","
891 [ pretty nm <+> ":" <++> pretty d | (nm, d) <- xs ]
892
893 pretty (DomainMatrix index innerNested)
894 = "matrix indexed by" <+> prettyList prBrackets "," indices
895 <+> "of" <++> pretty inner
896 where
897 (indices,inner) = first (index:) $ collect innerNested
898 collect (DomainMatrix i j) = first (i:) $ collect j
899 collect x = ([],x)
900
901 pretty (DomainSet r attrs inner) =
902 "set" <+> prettyAttrs r attrs <+> "of" <++> pretty inner
903
904 pretty (DomainMSet r attrs inner) =
905 "mset" <+> prettyAttrs r attrs <+> "of" <++> pretty inner
906
907 pretty (DomainFunction r attrs innerFrom innerTo) =
908 "function" <+> prettyAttrs r attrs <++> pretty innerFrom <++> "-->" <++> pretty innerTo
909
910 pretty (DomainSequence r attrs inner) =
911 "sequence" <+> prettyAttrs r attrs <+> "of" <++> pretty inner
912
913 pretty (DomainRelation r attrs inners)
914 = "relation" <+> prettyAttrs r attrs <+> "of" <++> prettyList prParens " *" inners
915
916 pretty (DomainPartition r attrs inner)
917 = "partition" <+> prettyAttrs r attrs <+> "from" <++> pretty inner
918
919 pretty d@DomainOp{} = pretty (show d)
920
921 pretty (DomainReference x _) = pretty x
922
923 pretty (DomainMetaVar x) = "&" <> pretty x
924
925
926 prettyAttrs :: (Pretty a, Pretty b) => a -> b -> Doc
927 prettyAttrs a bs =
928 let prettya = pretty a
929 in if show prettya == "()"
930 then pretty bs
931 else prBraces prettya <+> pretty bs
932
933 instance Pretty a => Pretty (DomainAttributes a) where
934 pretty (DomainAttributes []) = prEmpty
935 pretty (DomainAttributes attrs) = prettyList prParens "," attrs
936
937 instance Pretty a => Pretty (DomainAttribute a) where
938 pretty (DAName name) = pretty name
939 pretty (DANameValue name value) = pretty name <+> pretty value
940 pretty DADotDot = ".."
941
942 instance Pretty a => Pretty (Range a) where
943 pretty RangeOpen = ".."
944 pretty (RangeSingle x) = pretty x
945 pretty (RangeLowerBounded x) = pretty x <> ".."
946 pretty (RangeUpperBounded x) = ".." <> pretty x
947 pretty (RangeBounded x y) | show (pretty x) == show (pretty y) = pretty x
948 pretty (RangeBounded x y) = pretty x <> ".." <> pretty y
949
950 instance Pretty HasRepresentation where
951 pretty NoRepresentation = "∅"
952 pretty r = pretty (representationToFullText r)
953
954 textToRepresentation :: Text -> [HasRepresentation] -> Maybe HasRepresentation
955 textToRepresentation t [] | t == "Occurrence" = return Set_Occurrence
956 textToRepresentation t [] | t == "Explicit" = return Set_Explicit
957 textToRepresentation t [] | t == "ExplicitVarSizeWithFlags" = return Set_ExplicitVarSizeWithFlags
958 textToRepresentation t [] | t == "ExplicitVarSizeWithMarker" = return Set_ExplicitVarSizeWithMarker
959 textToRepresentation t [] | t == "ExplicitVarSizeWithDummy" = return Set_ExplicitVarSizeWithDummy
960 textToRepresentation t [] | t == "MOccurrence" = return MSet_Occurrence
961 textToRepresentation t [] | t == "ExplicitWithFlags" = return MSet_ExplicitWithFlags
962 textToRepresentation t [] | t == "ExplicitWithRepetition" = return MSet_ExplicitWithRepetition
963 textToRepresentation t [] | t == "Function1D" = return Function_1D
964 textToRepresentation t [] | t == "Function1DPartial" = return Function_1DPartial
965 textToRepresentation t [] | t == "FunctionND" = return Function_ND
966 textToRepresentation t [] | t == "FunctionNDPartial" = return Function_NDPartial
967 textToRepresentation t [] | t == "FunctionNDPartialDummy" = return Function_NDPartialDummy
968 textToRepresentation t [repr] | t == "FunctionAsRelation" = return (Function_AsRelation repr)
969 textToRepresentation t [] | t == "ExplicitBounded" = return Sequence_ExplicitBounded
970 textToRepresentation t [] | t == "RelationAsMatrix" = return Relation_AsMatrix
971 textToRepresentation t [repr] | t == "RelationAsSet" = return (Relation_AsSet repr)
972 textToRepresentation t [repr1, repr2] | t == "PartitionAsSet" = return (Partition_AsSet repr1 repr2)
973 textToRepresentation t [] | t == "PartitionOccurrence" = return Partition_Occurrence
974 textToRepresentation _ _ = Nothing
975
976 representationToShortText :: HasRepresentation -> Text
977 representationToShortText Set_Occurrence = "Occurrence"
978 representationToShortText Set_Explicit = "Explicit"
979 representationToShortText Set_ExplicitVarSizeWithFlags = "ExplicitVarSizeWithFlags"
980 representationToShortText Set_ExplicitVarSizeWithMarker = "ExplicitVarSizeWithMarker"
981 representationToShortText Set_ExplicitVarSizeWithDummy = "ExplicitVarSizeWithDummy"
982 representationToShortText MSet_Occurrence = "MOccurrence"
983 representationToShortText MSet_ExplicitWithFlags = "ExplicitWithFlags"
984 representationToShortText MSet_ExplicitWithRepetition = "ExplicitWithRepetition"
985 representationToShortText Function_1D = "Function1D"
986 representationToShortText Function_1DPartial = "Function1DPartial"
987 representationToShortText Function_ND = "FunctionND"
988 representationToShortText Function_NDPartial = "FunctionNDPartial"
989 representationToShortText Function_NDPartialDummy = "FunctionNDPartialDummy"
990 representationToShortText Function_AsRelation{} = "FunctionAsRelation"
991 representationToShortText Sequence_ExplicitBounded = "ExplicitBounded"
992 representationToShortText Relation_AsMatrix = "RelationAsMatrix"
993 representationToShortText Relation_AsSet{} = "RelationAsSet"
994 representationToShortText Partition_AsSet{} = "PartitionAsSet"
995 representationToShortText Partition_Occurrence = "PartitionOccurrence"
996 representationToShortText r = bug ("representationToShortText:" <+> pretty (show r))
997
998 representationToFullText :: HasRepresentation -> Text
999 representationToFullText (Function_AsRelation repr) = mconcat [ "FunctionAsRelation"
1000 , "["
1001 , representationToFullText repr
1002 , "]"
1003 ]
1004 representationToFullText (Relation_AsSet repr) = mconcat [ "RelationAsSet"
1005 , "["
1006 , representationToFullText repr
1007 , "]"
1008 ]
1009 representationToFullText (Partition_AsSet repr1 repr2) = mconcat [ "PartitionAsSet"
1010 , "["
1011 , representationToFullText repr1
1012 , ","
1013 , representationToFullText repr2
1014 , "]"
1015 ]
1016 representationToFullText r = representationToShortText r
1017
1018
1019 normaliseDomain :: (Ord c, ExpressionLike c) => (c -> c) -> Domain r c -> Domain r c
1020 normaliseDomain _norm DomainBool = DomainBool
1021 normaliseDomain norm (DomainInt t rs ) = DomainInt t $ sort $ map (normaliseRange norm) (expandRanges rs)
1022 normaliseDomain _norm (DomainEnum n Nothing mp) = DomainEnum n Nothing mp
1023 normaliseDomain _norm (DomainEnum n (Just rs) mp) = DomainEnum n (Just $ sort rs) mp
1024 normaliseDomain norm (DomainUnnamed n x ) = DomainUnnamed n (norm x)
1025 normaliseDomain norm (DomainRecord doms ) = DomainRecord [ (n, normaliseDomain norm d)
1026 | (n, d) <- doms ]
1027 normaliseDomain norm (DomainVariant doms ) = DomainVariant [ (n, normaliseDomain norm d)
1028 | (n, d) <- doms ]
1029 normaliseDomain norm (DomainTuple doms ) = DomainTuple $ map (normaliseDomain norm) doms
1030 normaliseDomain norm (DomainMatrix dom1 dom2) = DomainMatrix (normaliseDomain norm dom1)
1031 (normaliseDomain norm dom2)
1032 normaliseDomain norm (DomainSet r attr dom ) = DomainSet r (fmap norm attr)
1033 (normaliseDomain norm dom)
1034 normaliseDomain norm (DomainMSet r attr dom ) = DomainMSet r (fmap norm attr)
1035 (normaliseDomain norm dom)
1036 normaliseDomain norm (DomainFunction r attr dom1 dom2) = DomainFunction r (fmap norm attr)
1037 (normaliseDomain norm dom1)
1038 (normaliseDomain norm dom2)
1039 normaliseDomain norm (DomainSequence r attr dom ) = DomainSequence r (fmap norm attr)
1040 (normaliseDomain norm dom)
1041 normaliseDomain norm (DomainRelation r attr doms ) = DomainRelation r (fmap norm attr)
1042 (map (normaliseDomain norm) doms)
1043 normaliseDomain norm (DomainPartition r attr dom ) = DomainPartition r (fmap norm attr)
1044 (normaliseDomain norm dom)
1045 normaliseDomain _norm d = d
1046
1047 normaliseRange :: (c -> c) -> Range c -> Range c
1048 normaliseRange _norm RangeOpen = RangeOpen
1049 normaliseRange norm (RangeSingle x) = RangeBounded (norm x) (norm x)
1050 normaliseRange norm (RangeLowerBounded x) = RangeLowerBounded (norm x)
1051 normaliseRange norm (RangeUpperBounded x) = RangeUpperBounded (norm x)
1052 normaliseRange norm (RangeBounded x y) = RangeBounded (norm x) (norm y)
1053
1054 innerDomainOf :: (MonadFailDoc m, Show x) => Domain () x -> m (Domain () x)
1055 innerDomainOf (DomainMatrix _ t) = return t
1056 innerDomainOf (DomainSet _ _ t) = return t
1057 innerDomainOf (DomainMSet _ _ t) = return t
1058 innerDomainOf (DomainFunction _ _ a b) = return (DomainTuple [a,b])
1059 innerDomainOf (DomainRelation _ _ ts) = return (DomainTuple ts)
1060 innerDomainOf (DomainPartition _ _ t) = return (DomainSet () def t)
1061 innerDomainOf t = failDoc ("innerDomainOf:" <+> pretty (show t))
1062
1063 singletonDomainInt :: (Eq x, CanBeAnAlias x) => Domain r x -> Maybe x
1064 singletonDomainInt (DomainInt _ [RangeSingle a]) = Just a
1065 singletonDomainInt (DomainInt _ [RangeBounded a b]) =
1066 let
1067 followAlias (isAlias -> Just x) = followAlias x
1068 followAlias x = x
1069 in
1070 if followAlias a == followAlias b
1071 then Just a
1072 else Nothing
1073 singletonDomainInt _ = Nothing
1074
1075 matrixNumDimsD :: Domain r x -> Int
1076 matrixNumDimsD (DomainMatrix _ t) = 1 + matrixNumDimsD t
1077 matrixNumDimsD _ = 0