never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2 {-# LANGUAGE UndecidableInstances #-}
3
4 module Conjure.Compute.DomainOf ( DomainOf(..), domainOfR ) where
5
6 -- conjure
7 import Conjure.Prelude
8 import Conjure.Bug
9
10 import Conjure.Language
11 import Conjure.Language.RepresentationOf ( RepresentationOf(..) )
12 import Conjure.Compute.DomainUnion
13
14
15 type Dom = Domain () Expression
16
17 class DomainOf a where
18
19 -- | calculate the domain of `a`
20 domainOf ::
21 MonadFailDoc m =>
22 NameGen m =>
23 (?typeCheckerMode :: TypeCheckerMode) =>
24 a -> m Dom
25
26 -- | calculate the index domains of `a`
27 -- the index is the index of a matrix.
28 -- returns [] for non-matrix inputs.
29 -- has a default implementation in terms of domainOf, so doesn't need to be implemented specifically.
30 -- but sometimes it is better to implement this directly.
31 indexDomainsOf ::
32 MonadFailDoc m =>
33 NameGen m =>
34 Pretty a =>
35 (?typeCheckerMode :: TypeCheckerMode) =>
36 a -> m [Dom]
37 indexDomainsOf = defIndexDomainsOf
38
39
40 domainOfR ::
41 DomainOf a =>
42 RepresentationOf a =>
43 MonadFailDoc m =>
44 NameGen m =>
45 (?typeCheckerMode :: TypeCheckerMode) =>
46 a -> m (Domain HasRepresentation Expression)
47 domainOfR inp = do
48 dom <- domainOf inp
49 rTree <- representationTreeOf inp
50 applyReprTree dom rTree
51
52
53 defIndexDomainsOf ::
54 MonadFailDoc m =>
55 NameGen m =>
56 DomainOf a =>
57 (?typeCheckerMode :: TypeCheckerMode) =>
58 a -> m [Dom]
59 defIndexDomainsOf x = do
60 dom <- domainOf x
61 let
62 collect (DomainMatrix index inner) = index : collect inner
63 collect _ = []
64 return (collect dom)
65
66 instance DomainOf ReferenceTo where
67 domainOf (Alias x) = domainOf x
68 domainOf (InComprehension (GenDomainNoRepr Single{} dom)) = return dom
69 domainOf (InComprehension (GenDomainHasRepr _ dom)) = return (forgetRepr dom)
70 domainOf (InComprehension (GenInExpr Single{} x)) = domainOf x >>= innerDomainOf
71 domainOf x@InComprehension{} = failDoc $ vcat [ "domainOf-ReferenceTo-InComprehension", pretty x, pretty (show x) ]
72 domainOf (DeclNoRepr _ _ dom _) = return dom
73 domainOf (DeclHasRepr _ _ dom ) = return (forgetRepr dom)
74 domainOf RecordField{} = failDoc "domainOf-ReferenceTo-RecordField"
75 domainOf VariantField{} = failDoc "domainOf-ReferenceTo-VariantField"
76
77
78 instance DomainOf Expression where
79 domainOf (Reference _ (Just refTo)) = domainOf refTo
80 domainOf (Constant x) = domainOf x
81 domainOf (AbstractLiteral x) = domainOf x
82 domainOf (Op x) = domainOf x
83 domainOf (WithLocals h _) = domainOf h
84 domainOf (Comprehension h _) = do
85 domH <- domainOf h
86 return $ DomainMatrix (DomainInt TagInt [RangeLowerBounded 1]) domH
87 domainOf x = failDoc ("domainOf{Expression}:" <+> pretty (show x))
88
89 -- if an empty matrix literal has a type annotation
90 indexDomainsOf (Typed lit ty) | emptyCollectionX lit =
91 let
92 tyToDom (TypeMatrix (TypeInt nm) t) = DomainInt nm [RangeBounded 1 0] : tyToDom t
93 tyToDom _ = []
94 in
95 return (tyToDom ty)
96
97 indexDomainsOf (Reference _ (Just refTo)) = indexDomainsOf refTo
98 indexDomainsOf (Constant x) = indexDomainsOf x
99 indexDomainsOf (AbstractLiteral x) = indexDomainsOf x
100 indexDomainsOf (Op x) = indexDomainsOf x
101 indexDomainsOf (WithLocals h _) = indexDomainsOf h
102 indexDomainsOf x = failDoc ("indexDomainsOf{Expression}:" <+> pretty (show x))
103
104 -- this should be better implemented by some ghc-generics magic
105 instance (DomainOf x, TypeOf x, Pretty x, ExpressionLike x, Domain () x :< x, Dom :< x) => DomainOf (Op x) where
106 domainOf (MkOpActive x) = domainOf x
107 domainOf (MkOpAllDiff x) = domainOf x
108 domainOf (MkOpAllDiffExcept x) = domainOf x
109 domainOf (MkOpAnd x) = domainOf x
110 domainOf (MkOpApart x) = domainOf x
111 domainOf (MkOpCompose x) = domainOf x
112 domainOf (MkOpAtLeast x) = domainOf x
113 domainOf (MkOpAtMost x) = domainOf x
114 domainOf (MkOpAttributeAsConstraint x) = domainOf x
115 domainOf (MkOpCatchUndef x) = domainOf x
116 domainOf (MkOpDefined x) = domainOf x
117 domainOf (MkOpDiv x) = domainOf x
118 domainOf (MkOpDontCare x) = domainOf x
119 domainOf (MkOpDotLeq x) = domainOf x
120 domainOf (MkOpDotLt x) = domainOf x
121 domainOf (MkOpEq x) = domainOf x
122 domainOf (MkOpElementId x) = domainOf x
123 domainOf (MkOpFactorial x) = domainOf x
124 domainOf (MkOpFlatten x) = domainOf x
125 domainOf (MkOpFreq x) = domainOf x
126 domainOf (MkOpGCC x) = domainOf x
127 domainOf (MkOpGeq x) = domainOf x
128 domainOf (MkOpGt x) = domainOf x
129 domainOf (MkOpHist x) = domainOf x
130 domainOf (MkOpIff x) = domainOf x
131 domainOf (MkOpImage x) = domainOf x
132 domainOf (MkOpImageSet x) = domainOf x
133 domainOf (MkOpImply x) = domainOf x
134 domainOf (MkOpIn x) = domainOf x
135 domainOf (MkOpIndexing x) = domainOf x
136 domainOf (MkOpIntersect x) = domainOf x
137 domainOf (MkOpInverse x) = domainOf x
138 domainOf (MkOpLeq x) = domainOf x
139 domainOf (MkOpLexLeq x) = domainOf x
140 domainOf (MkOpLexLt x) = domainOf x
141 domainOf (MkOpLt x) = domainOf x
142 domainOf (MkOpMakeTable x) = domainOf x
143 domainOf (MkOpMax x) = domainOf x
144 domainOf (MkOpMin x) = domainOf x
145 domainOf (MkOpMinus x) = domainOf x
146 domainOf (MkOpMod x) = domainOf x
147 domainOf (MkOpNegate x) = domainOf x
148 domainOf (MkOpNeq x) = domainOf x
149 domainOf (MkOpNot x) = domainOf x
150 domainOf (MkOpOr x) = domainOf x
151 domainOf (MkOpParticipants x) = domainOf x
152 domainOf (MkOpParts x) = domainOf x
153 domainOf (MkOpParty x) = domainOf x
154 domainOf (MkOpPermInverse x) = domainOf x
155 domainOf (MkOpPow x) = domainOf x
156 domainOf (MkOpPowerSet x) = domainOf x
157 domainOf (MkOpPred x) = domainOf x
158 domainOf (MkOpPreImage x) = domainOf x
159 domainOf (MkOpProduct x) = domainOf x
160 domainOf (MkOpRange x) = domainOf x
161 domainOf (MkOpRelationProj x) = domainOf x
162 domainOf (MkOpRestrict x) = domainOf x
163 domainOf (MkOpSlicing x) = domainOf x
164 domainOf (MkOpSubsequence x) = domainOf x
165 domainOf (MkOpSubset x) = domainOf x
166 domainOf (MkOpSubsetEq x) = domainOf x
167 domainOf (MkOpSubstring x) = domainOf x
168 domainOf (MkOpSucc x) = domainOf x
169 domainOf (MkOpSum x) = domainOf x
170 domainOf (MkOpSupset x) = domainOf x
171 domainOf (MkOpSupsetEq x) = domainOf x
172 domainOf (MkOpTable x) = domainOf x
173 domainOf (MkOpTildeLeq x) = domainOf x
174 domainOf (MkOpTildeLt x) = domainOf x
175 domainOf (MkOpTogether x) = domainOf x
176 domainOf (MkOpToInt x) = domainOf x
177 domainOf (MkOpToMSet x) = domainOf x
178 domainOf (MkOpToRelation x) = domainOf x
179 domainOf (MkOpToSet x) = domainOf x
180 domainOf (MkOpTransform x) = domainOf x
181 domainOf (MkOpTrue x) = domainOf x
182 domainOf (MkOpTwoBars x) = domainOf x
183 domainOf (MkOpUnion x) = domainOf x
184 domainOf (MkOpXor x) = domainOf x
185 domainOf (MkOpQuickPermutationOrder x) = domainOf x
186
187 indexDomainsOf (MkOpActive x) = indexDomainsOf x
188 indexDomainsOf (MkOpAllDiff x) = indexDomainsOf x
189 indexDomainsOf (MkOpAllDiffExcept x) = indexDomainsOf x
190 indexDomainsOf (MkOpAnd x) = indexDomainsOf x
191 indexDomainsOf (MkOpApart x) = indexDomainsOf x
192 indexDomainsOf (MkOpCompose x) = indexDomainsOf x
193 indexDomainsOf (MkOpAtLeast x) = indexDomainsOf x
194 indexDomainsOf (MkOpAtMost x) = indexDomainsOf x
195 indexDomainsOf (MkOpAttributeAsConstraint x) = indexDomainsOf x
196 indexDomainsOf (MkOpCatchUndef x) = indexDomainsOf x
197 indexDomainsOf (MkOpDefined x) = indexDomainsOf x
198 indexDomainsOf (MkOpDiv x) = indexDomainsOf x
199 indexDomainsOf (MkOpDontCare x) = indexDomainsOf x
200 indexDomainsOf (MkOpDotLeq x) = indexDomainsOf x
201 indexDomainsOf (MkOpDotLt x) = indexDomainsOf x
202 indexDomainsOf (MkOpEq x) = indexDomainsOf x
203 indexDomainsOf (MkOpElementId x) = indexDomainsOf x
204 indexDomainsOf (MkOpFactorial x) = indexDomainsOf x
205 indexDomainsOf (MkOpFlatten x) = indexDomainsOf x
206 indexDomainsOf (MkOpFreq x) = indexDomainsOf x
207 indexDomainsOf (MkOpGCC x) = indexDomainsOf x
208 indexDomainsOf (MkOpGeq x) = indexDomainsOf x
209 indexDomainsOf (MkOpGt x) = indexDomainsOf x
210 indexDomainsOf (MkOpHist x) = indexDomainsOf x
211 indexDomainsOf (MkOpIff x) = indexDomainsOf x
212 indexDomainsOf (MkOpImage x) = indexDomainsOf x
213 indexDomainsOf (MkOpImageSet x) = indexDomainsOf x
214 indexDomainsOf (MkOpImply x) = indexDomainsOf x
215 indexDomainsOf (MkOpIn x) = indexDomainsOf x
216 indexDomainsOf (MkOpIndexing x) = indexDomainsOf x
217 indexDomainsOf (MkOpIntersect x) = indexDomainsOf x
218 indexDomainsOf (MkOpInverse x) = indexDomainsOf x
219 indexDomainsOf (MkOpLeq x) = indexDomainsOf x
220 indexDomainsOf (MkOpLexLeq x) = indexDomainsOf x
221 indexDomainsOf (MkOpLexLt x) = indexDomainsOf x
222 indexDomainsOf (MkOpLt x) = indexDomainsOf x
223 indexDomainsOf (MkOpMakeTable x) = indexDomainsOf x
224 indexDomainsOf (MkOpMax x) = indexDomainsOf x
225 indexDomainsOf (MkOpMin x) = indexDomainsOf x
226 indexDomainsOf (MkOpMinus x) = indexDomainsOf x
227 indexDomainsOf (MkOpMod x) = indexDomainsOf x
228 indexDomainsOf (MkOpNegate x) = indexDomainsOf x
229 indexDomainsOf (MkOpNeq x) = indexDomainsOf x
230 indexDomainsOf (MkOpNot x) = indexDomainsOf x
231 indexDomainsOf (MkOpOr x) = indexDomainsOf x
232 indexDomainsOf (MkOpParticipants x) = indexDomainsOf x
233 indexDomainsOf (MkOpParts x) = indexDomainsOf x
234 indexDomainsOf (MkOpParty x) = indexDomainsOf x
235 indexDomainsOf (MkOpPermInverse x) = indexDomainsOf x
236 indexDomainsOf (MkOpPow x) = indexDomainsOf x
237 indexDomainsOf (MkOpPowerSet x) = indexDomainsOf x
238 indexDomainsOf (MkOpPred x) = indexDomainsOf x
239 indexDomainsOf (MkOpPreImage x) = indexDomainsOf x
240 indexDomainsOf (MkOpProduct x) = indexDomainsOf x
241 indexDomainsOf (MkOpRange x) = indexDomainsOf x
242 indexDomainsOf (MkOpRelationProj x) = indexDomainsOf x
243 indexDomainsOf (MkOpRestrict x) = indexDomainsOf x
244 indexDomainsOf (MkOpSlicing x) = indexDomainsOf x
245 indexDomainsOf (MkOpSubsequence x) = indexDomainsOf x
246 indexDomainsOf (MkOpSubset x) = indexDomainsOf x
247 indexDomainsOf (MkOpSubsetEq x) = indexDomainsOf x
248 indexDomainsOf (MkOpSubstring x) = indexDomainsOf x
249 indexDomainsOf (MkOpSucc x) = indexDomainsOf x
250 indexDomainsOf (MkOpSum x) = indexDomainsOf x
251 indexDomainsOf (MkOpSupset x) = indexDomainsOf x
252 indexDomainsOf (MkOpSupsetEq x) = indexDomainsOf x
253 indexDomainsOf (MkOpTable x) = indexDomainsOf x
254 indexDomainsOf (MkOpTildeLeq x) = indexDomainsOf x
255 indexDomainsOf (MkOpTildeLt x) = indexDomainsOf x
256 indexDomainsOf (MkOpTogether x) = indexDomainsOf x
257 indexDomainsOf (MkOpToInt x) = indexDomainsOf x
258 indexDomainsOf (MkOpToMSet x) = indexDomainsOf x
259 indexDomainsOf (MkOpToRelation x) = indexDomainsOf x
260 indexDomainsOf (MkOpToSet x) = indexDomainsOf x
261 indexDomainsOf (MkOpTransform (OpTransform _ x)) = indexDomainsOf x
262 indexDomainsOf (MkOpTrue x) = indexDomainsOf x
263 indexDomainsOf (MkOpTwoBars x) = indexDomainsOf x
264 indexDomainsOf (MkOpUnion x) = indexDomainsOf x
265 indexDomainsOf (MkOpXor x) = indexDomainsOf x
266 indexDomainsOf (MkOpQuickPermutationOrder x) = indexDomainsOf x
267
268 instance DomainOf Constant where
269 domainOf ConstantBool{} = return DomainBool
270 domainOf i@(ConstantInt t _) = return $ DomainInt t [RangeSingle (Constant i)]
271 domainOf (ConstantEnum defn _ _ ) = return (DomainEnum defn Nothing Nothing)
272 domainOf ConstantField{} = failDoc "DomainOf-ConstantField"
273 domainOf (ConstantAbstract x) = domainOf (fmap Constant x)
274 domainOf (DomainInConstant dom) = return (fmap Constant dom)
275 domainOf (TypedConstant x ty) = domainOf (Typed (Constant x) ty)
276 domainOf ConstantUndefined{} = failDoc "DomainOf-ConstantUndefined"
277
278 indexDomainsOf ConstantBool{} = return []
279 indexDomainsOf ConstantInt{} = return []
280 indexDomainsOf ConstantEnum{} = return []
281 indexDomainsOf ConstantField{} = return []
282 indexDomainsOf (ConstantAbstract x) = indexDomainsOf (fmap Constant x)
283 indexDomainsOf DomainInConstant{} = return []
284 indexDomainsOf (TypedConstant x ty) = indexDomainsOf (Typed (Constant x) ty)
285 indexDomainsOf ConstantUndefined{} = return []
286
287 instance DomainOf (AbstractLiteral Expression) where
288
289 domainOf (AbsLitTuple xs) = DomainTuple <$> mapM domainOf xs
290
291 domainOf (AbsLitRecord xs) = DomainRecord <$> sequence [ do t <- domainOf x ; return (n,t)
292 | (n,x) <- xs ]
293
294 domainOf (AbsLitVariant Nothing _ _) = failDoc "Cannot calculate the domain of variant literal."
295 domainOf (AbsLitVariant (Just t) _ _) = return (DomainVariant t)
296
297 domainOf (AbsLitMatrix ind inn ) = DomainMatrix ind <$> (domainUnions =<< mapM domainOf inn)
298
299 domainOf (AbsLitSet [] ) = return $ DomainSet def attr (DomainAny "domainOf-AbsLitSet-[]" TypeAny)
300 where attr = SetAttr (SizeAttr_Size 0)
301 domainOf (AbsLitSet xs ) = DomainSet def attr <$> (domainUnions =<< mapM domainOf xs)
302 where attr = SetAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs)
303
304 domainOf (AbsLitMSet [] ) = return $ DomainMSet def attr (DomainAny "domainOf-AbsLitMSet-[]" TypeAny)
305 where attr = MSetAttr (SizeAttr_Size 0) OccurAttr_None
306 domainOf (AbsLitMSet xs ) = DomainMSet def attr <$> (domainUnions =<< mapM domainOf xs)
307 where attr = MSetAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs) OccurAttr_None
308
309 domainOf (AbsLitFunction [] ) = return $ DomainFunction def attr
310 (DomainAny "domainOf-AbsLitFunction-[]-1" TypeAny)
311 (DomainAny "domainOf-AbsLitFunction-[]-2" TypeAny)
312 where attr = FunctionAttr (SizeAttr_Size 0) def def
313 domainOf (AbsLitFunction xs ) = DomainFunction def attr
314 <$> (domainUnions =<< mapM (domainOf . fst) xs)
315 <*> (domainUnions =<< mapM (domainOf . snd) xs)
316 where attr = FunctionAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs) def def
317
318 domainOf (AbsLitSequence [] ) = return $ DomainSequence def attr
319 (DomainAny "domainOf-AbsLitSequence-[]" TypeAny)
320 where attr = SequenceAttr (SizeAttr_Size 0) def
321 domainOf (AbsLitSequence xs ) = DomainSequence def attr
322 <$> (domainUnions =<< mapM domainOf xs)
323 where attr = SequenceAttr (SizeAttr_MaxSize (fromInt $ genericLength xs)) def
324
325 domainOf (AbsLitRelation [] ) = return $ DomainRelation def attr []
326 where attr = RelationAttr (SizeAttr_Size 0) def
327 domainOf (AbsLitRelation xss) = do
328 ty <- domainUnions =<< mapM (domainOf . AbsLitTuple) xss
329 case ty of
330 DomainTuple ts -> return (DomainRelation def attr ts)
331 _ -> bug "expecting DomainTuple in domainOf"
332 where attr = RelationAttr (SizeAttr_MaxSize (fromInt $ genericLength xss)) def
333
334 domainOf (AbsLitPartition [] ) = return $ DomainPartition def attr
335 (DomainAny "domainOf-AbsLitPartition-[]" TypeAny)
336 where attr = PartitionAttr (SizeAttr_Size 0) (SizeAttr_Size 0) False
337 domainOf (AbsLitPartition xss) = DomainPartition def attr <$> (domainUnions =<< mapM domainOf (concat xss))
338 where attr = PartitionAttr (SizeAttr_MaxSize (fromInt $ genericLength xss))
339 (SizeAttr_MaxSize (fromInt $ maximum [genericLength xs | xs <- xss]))
340 False
341 domainOf (AbsLitPermutation [] ) = return $ DomainPermutation def (PermutationAttr SizeAttr_None) (DomainAny "domainOf-AbsLitPermutation-[]" TypeAny)
342 domainOf (AbsLitPermutation xss) = DomainPermutation def (PermutationAttr SizeAttr_None) <$> (domainUnions =<< mapM domainOf (concat xss))
343
344 indexDomainsOf (AbsLitMatrix ind inn) = do
345 innerIndices <- mapM indexDomainsOf inn
346 if all null innerIndices
347 then return [ind]
348 else (ind :) <$> (mapM domainUnions innerIndices)
349 indexDomainsOf _ = return []
350
351
352
353
354 -- all the `Op`s
355
356 instance DomainOf (OpActive x) where
357 domainOf _ = return DomainBool
358
359 instance DomainOf (OpAllDiff x) where
360 domainOf _ = return DomainBool
361
362 instance DomainOf (OpAllDiffExcept x) where
363 domainOf _ = return DomainBool
364
365 instance DomainOf x => DomainOf (OpCatchUndef x) where
366 domainOf (OpCatchUndef x _) = domainOf x
367
368 instance DomainOf (OpAnd x) where
369 domainOf _ = return DomainBool
370
371 instance DomainOf (OpApart x) where
372 domainOf _ = return DomainBool
373
374 instance DomainOf (OpAttributeAsConstraint x) where
375 domainOf _ = return DomainBool
376
377 instance DomainOf x => DomainOf (OpDefined x) where
378 domainOf (OpDefined f) = do
379 fDom <- domainOf f
380 case fDom of
381 DomainFunction _ _ fr _ -> return $ DomainSet def def fr
382 _ -> failDoc "domainOf, OpDefined, not a function"
383
384 instance DomainOf x => DomainOf (OpDiv x) where
385 domainOf (OpDiv x y) = do
386 xDom :: Dom <- domainOf x
387 yDom :: Dom <- domainOf y
388 (iPat, i) <- quantifiedVar
389 (jPat, j) <- quantifiedVar
390 let vals = [essence| [ &i / &j
391 | &iPat : &xDom
392 , &jPat : &yDom
393 ] |]
394 let low = [essence| min(&vals) |]
395 let upp = [essence| max(&vals) |]
396 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
397
398 instance DomainOf (OpDontCare x) where
399 domainOf _ = return DomainBool
400
401 instance DomainOf (OpDotLeq x) where
402 domainOf _ = return DomainBool
403
404 instance DomainOf (OpDotLt x) where
405 domainOf _ = return DomainBool
406
407 instance DomainOf (OpEq x) where
408 domainOf _ = return DomainBool
409
410 instance (Pretty x, TypeOf x) => DomainOf (OpFactorial x) where
411 domainOf op = mkDomainAny ("OpFactorial:" <++> pretty op) <$> typeOf op
412
413 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpFlatten x) where
414 domainOf (OpFlatten (Just 1) x) = domainOf x >>= innerDomainOf
415 domainOf op = mkDomainAny ("OpFlatten:" <++> pretty op) <$> typeOf op
416
417 instance (Pretty x, TypeOf x) => DomainOf (OpFreq x) where
418 domainOf op = mkDomainAny ("OpFreq:" <++> pretty op) <$> typeOf op
419
420 instance DomainOf (OpGeq x) where
421 domainOf _ = return DomainBool
422
423 instance DomainOf (OpGt x) where
424 domainOf _ = return DomainBool
425
426 instance (Pretty x, TypeOf x) => DomainOf (OpHist x) where
427 domainOf op = mkDomainAny ("OpHist:" <++> pretty op) <$> typeOf op
428
429 instance DomainOf (OpIff x) where
430 domainOf _ = return DomainBool
431
432 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpImage x) where
433 domainOf (OpImage f _) = do
434 fDomain <- domainOf f
435 case fDomain of
436 DomainFunction _ _ _ to -> return to
437 DomainSequence _ _ to -> return to
438 DomainPermutation _ _ ov -> return ov
439 _ -> failDoc "domainOf, OpImage, not a function, sequence or permutation"
440
441 instance (Pretty x, TypeOf x) => DomainOf (OpImageSet x) where
442 domainOf op = mkDomainAny ("OpImageSet:" <++> pretty op) <$> typeOf op
443
444 instance DomainOf (OpImply x) where
445 domainOf _ = return DomainBool
446
447 instance DomainOf (OpIn x) where
448 domainOf _ = return DomainBool
449
450 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x) => DomainOf (OpElementId x) where
451 domainOf (OpElementId m i) = do
452 iType <- typeOf i
453 case iType of
454 TypeBool{} -> return ()
455 TypeInt{} -> return ()
456 TypeMatrix{} -> return ()
457 _ -> failDoc "domainOf, OpElementId, not a bool or int index"
458 mDom <- domainOf m
459 case mDom of
460 DomainMatrix _ inner -> return inner
461 _ -> failDoc "domainOf, OpElementId, not a matrix or tuple"
462
463 indexDomainsOf p@(OpElementId m i) = do
464 iType <- typeOf i
465 case iType of
466 TypeBool{} -> return ()
467 TypeInt{} -> return ()
468 TypeMatrix{} -> return ()
469 _ -> failDoc "domainOf, OpElementId, not a bool or int index"
470 is <- indexDomainsOf m
471 case is of
472 [] -> failDoc ("indexDomainsOf{OpElementId}, not a matrix domain:" <++> pretty p)
473 (_:is') -> return is'
474
475 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x) => DomainOf (OpIndexing x) where
476 domainOf (OpIndexing m i) = do
477 iType <- typeOf i
478 case iType of
479 TypeBool{} -> return ()
480 TypeInt{} -> return ()
481 TypeMatrix{} -> return ()
482 _ -> failDoc "domainOf, OpIndexing, not a bool or int index"
483 mDom <- domainOf m
484 case mDom of
485 DomainMatrix _ inner -> return inner
486 DomainTuple inners -> do
487 iInt <- intOut "domainOf OpIndexing" i
488 return $ atNote "domainOf" inners (fromInteger (iInt-1))
489 _ -> failDoc "domainOf, OpIndexing, not a matrix or tuple"
490
491 indexDomainsOf p@(OpIndexing m i) = do
492 iType <- typeOf i
493 case iType of
494 TypeBool{} -> return ()
495 TypeInt{} -> return ()
496 TypeMatrix{} -> return ()
497 _ -> failDoc "domainOf, OpIndexing, not a bool or int index"
498 is <- indexDomainsOf m
499 case is of
500 [] -> failDoc ("indexDomainsOf{OpIndexing}, not a matrix domain:" <++> pretty p)
501 (_:is') -> return is'
502
503 instance (Pretty x, TypeOf x) => DomainOf (OpIntersect x) where
504 domainOf op = mkDomainAny ("OpIntersect:" <++> pretty op) <$> typeOf op
505
506 instance DomainOf (OpInverse x) where
507 domainOf _ = return DomainBool
508
509 instance DomainOf (OpLeq x) where
510 domainOf _ = return DomainBool
511
512 instance DomainOf (OpLexLeq x) where
513 domainOf _ = return DomainBool
514
515 instance DomainOf (OpLexLt x) where
516 domainOf _ = return DomainBool
517
518 instance DomainOf (OpLt x) where
519 domainOf _ = return DomainBool
520
521 instance DomainOf (OpMakeTable x) where
522 domainOf _ = return DomainBool
523
524 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x, Domain () x :< x) => DomainOf (OpMax x) where
525 domainOf (OpMax x)
526 | Just xs <- listOut x
527 , not (null xs) = do
528 doms <- mapM domainOf xs
529 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
530 let low = [essence| max(&lows) |]
531 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
532 let upp = [essence| max(&upps) |]
533 case doms of
534 [] -> bug "domainOf OpMax"
535 (d:_) -> do
536 TypeInt t <- typeOfDomain d
537 return (DomainInt t [RangeBounded low upp] :: Dom)
538 domainOf op = mkDomainAny ("OpMax:" <++> pretty op) <$> typeOf op
539
540 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x, Domain () x :< x) => DomainOf (OpMin x) where
541 domainOf (OpMin x)
542 | Just xs <- listOut x
543 , not (null xs) = do
544 doms <- mapM domainOf xs
545 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
546 let low = [essence| min(&lows) |]
547 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
548 let upp = [essence| min(&upps) |]
549 case doms of
550 [] -> bug "domainOf OpMin"
551 (d:_) -> do
552 TypeInt t <- typeOfDomain d
553 return (DomainInt t [RangeBounded low upp] :: Dom)
554 domainOf op = mkDomainAny ("OpMin:" <++> pretty op) <$> typeOf op
555
556 instance DomainOf x => DomainOf (OpMinus x) where
557 domainOf (OpMinus x y) = do
558 xDom :: Dom <- domainOf x
559 yDom :: Dom <- domainOf y
560
561 xDom_Min <- minOfDomain xDom
562 xDom_Max <- maxOfDomain xDom
563 yDom_Min <- minOfDomain yDom
564 yDom_Max <- maxOfDomain yDom
565
566 let low = [essence| &xDom_Min - &yDom_Max |]
567 let upp = [essence| &xDom_Max - &yDom_Min |]
568
569 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
570
571 instance (Pretty x, TypeOf x) => DomainOf (OpMod x) where
572 domainOf op = mkDomainAny ("OpMod:" <++> pretty op) <$> typeOf op
573
574 instance (Pretty x, TypeOf x) => DomainOf (OpNegate x) where
575 domainOf op = mkDomainAny ("OpNegate:" <++> pretty op) <$> typeOf op
576
577 instance DomainOf (OpNeq x) where
578 domainOf _ = return DomainBool
579
580 instance DomainOf (OpNot x) where
581 domainOf _ = return DomainBool
582
583 instance DomainOf (OpOr x) where
584 domainOf _ = return DomainBool
585
586 instance DomainOf (OpXor x) where
587 domainOf _ = return DomainBool
588
589 instance (Pretty x, TypeOf x) => DomainOf (OpParticipants x) where
590 domainOf op = mkDomainAny ("OpParticipants:" <++> pretty op) <$> typeOf op
591
592 instance DomainOf x => DomainOf (OpParts x) where
593 domainOf (OpParts p) = do
594 dom <- domainOf p
595 case dom of
596 DomainPartition _ _ inner -> return $ DomainSet def def $ DomainSet def def inner
597 _ -> failDoc "domainOf, OpParts, not a partition"
598
599 instance (Pretty x, TypeOf x) => DomainOf (OpParty x) where
600 domainOf op = mkDomainAny ("OpParty:" <++> pretty op) <$> typeOf op
601
602 instance (Pretty x, TypeOf x) => DomainOf (OpPermInverse x) where
603 domainOf op = mkDomainAny ("OpPermInverse:" <++> pretty op) <$> typeOf op
604
605 instance (Pretty x, TypeOf x) => DomainOf (OpCompose x) where
606 domainOf op = mkDomainAny ("OpCompose:" <++> pretty op) <$> typeOf op
607
608 instance (Pretty x, TypeOf x) => DomainOf (OpPow x) where
609 domainOf op = mkDomainAny ("OpPow:" <++> pretty op) <$> typeOf op
610
611 instance (Pretty x, TypeOf x) => DomainOf (OpPowerSet x) where
612 domainOf op = mkDomainAny ("OpPowerSet:" <++> pretty op) <$> typeOf op
613
614 instance (Pretty x, TypeOf x) => DomainOf (OpPreImage x) where
615 domainOf op = mkDomainAny ("OpPreImage:" <++> pretty op) <$> typeOf op
616
617 instance DomainOf x => DomainOf (OpPred x) where
618 domainOf (OpPred x) = domainOf x -- TODO: improve
619
620 instance (ExpressionLike x, DomainOf x) => DomainOf (OpProduct x) where
621 domainOf (OpProduct x)
622 | Just xs <- listOut x
623 , not (null xs) = do
624 (iPat, i) <- quantifiedVar
625 doms <- mapM domainOf xs
626 -- maximum absolute value in each domain
627 let upps = fromList [ [essence| max([ |&i| | &iPat : &d ]) |]
628 | d <- doms ]
629 -- a (too lax) upper bound is multiplying all those together
630 let upp = [essence| product(&upps) |]
631 -- a (too lax) lower bound is -upp
632 let low = [essence| -1 * &upp |]
633 return $ DomainInt TagInt [RangeBounded low upp]
634 domainOf _ = return $ DomainInt TagInt [RangeBounded 1 1]
635
636 instance DomainOf x => DomainOf (OpRange x) where
637 domainOf (OpRange f) = do
638 fDom <- domainOf f
639 case fDom of
640 DomainFunction _ _ _ to -> return $ DomainSet def def to
641 _ -> failDoc "domainOf, OpRange, not a function"
642
643 instance (Pretty x, TypeOf x) => DomainOf (OpRelationProj x) where
644 domainOf op = mkDomainAny ("OpRelationProj:" <++> pretty op) <$> typeOf op
645
646 instance (DomainOf x, Dom :< x) => DomainOf (OpRestrict x) where
647 domainOf (OpRestrict f x) = do
648 d <- project x
649 fDom <- domainOf f
650 case fDom of
651 DomainFunction fRepr a _ to -> return (DomainFunction fRepr a d to)
652 _ -> failDoc "domainOf, OpRestrict, not a function"
653
654 instance (Pretty x, DomainOf x) => DomainOf (OpSlicing x) where
655 domainOf (OpSlicing x _ _) = domainOf x
656 indexDomainsOf (OpSlicing x _ _) = indexDomainsOf x
657
658 instance DomainOf (OpSubsequence x) where
659 domainOf _ = failDoc "domainOf{OpSubsequence}"
660
661 instance (Pretty x, TypeOf x) => DomainOf (OpSubset x) where
662 domainOf op = mkDomainAny ("OpSubset:" <++> pretty op) <$> typeOf op
663
664 instance (Pretty x, TypeOf x) => DomainOf (OpSubsetEq x) where
665 domainOf op = mkDomainAny ("OpSubsetEq:" <++> pretty op) <$> typeOf op
666
667 instance DomainOf (OpSubstring x) where
668 domainOf _ = failDoc "domainOf{OpSubstring}"
669
670 instance DomainOf x => DomainOf (OpSucc x) where
671 domainOf (OpSucc x) = domainOf x -- TODO: improve
672
673 instance (ExpressionLike x, DomainOf x) => DomainOf (OpSum x) where
674 domainOf (OpSum x)
675 | Just xs <- listOut x
676 , not (null xs) = do
677 doms <- mapM domainOf xs
678 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
679 let low = [essence| sum(&lows) |]
680 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
681 let upp = [essence| sum(&upps) |]
682 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
683 domainOf _ = return $ DomainInt TagInt [RangeBounded 0 0]
684
685
686 instance DomainOf (OpSupset x) where
687 domainOf _ = return DomainBool
688
689 instance DomainOf (OpSupsetEq x) where
690 domainOf _ = return DomainBool
691
692 instance DomainOf (OpTable x) where
693 domainOf _ = return DomainBool
694
695 instance DomainOf (OpAtLeast x) where
696 domainOf _ = return DomainBool
697
698 instance DomainOf (OpAtMost x) where
699 domainOf _ = return DomainBool
700
701 instance DomainOf (OpGCC x) where
702 domainOf _ = return DomainBool
703
704 instance DomainOf (OpTildeLeq x) where
705 domainOf _ = return DomainBool
706
707 instance DomainOf (OpTildeLt x) where
708 domainOf _ = return DomainBool
709
710 instance DomainOf (OpToInt x) where
711 domainOf _ = return $ DomainInt TagInt [RangeBounded 0 1]
712
713 instance (Pretty x, TypeOf x) => DomainOf (OpToMSet x) where
714 domainOf op = mkDomainAny ("OpToMSet:" <++> pretty op) <$> typeOf op
715
716 instance (Pretty x, TypeOf x) => DomainOf (OpToRelation x) where
717 domainOf op = mkDomainAny ("OpToRelation:" <++> pretty op) <$> typeOf op
718
719 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpToSet x) where
720 domainOf (OpToSet _ x) = do
721 domX <- domainOf x
722 innerDomX <- innerDomainOf domX
723 return $ DomainSet () def innerDomX
724
725 instance DomainOf (OpTogether x) where
726 domainOf _ = return DomainBool
727
728 instance (Pretty x, TypeOf x) => DomainOf (OpTransform x) where
729 domainOf op = mkDomainAny ("OpTransform:" <++> pretty op) <$> typeOf op
730
731 instance DomainOf (OpTrue x) where
732 domainOf _ = return DomainBool
733
734 instance (Pretty x, TypeOf x, Domain () x :< x) => DomainOf (OpTwoBars x) where
735 domainOf op = mkDomainAny ("OpTwoBars:" <++> pretty op) <$> typeOf op
736
737 instance (Pretty x, TypeOf x) => DomainOf (OpUnion x) where
738 domainOf op = mkDomainAny ("OpUnion:" <++> pretty op) <$> typeOf op
739
740 instance DomainOf (OpQuickPermutationOrder x) where
741 domainOf _ = return DomainBool