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