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 (MkOpAtLeast x) = domainOf x
112 domainOf (MkOpAtMost x) = domainOf x
113 domainOf (MkOpAttributeAsConstraint x) = domainOf x
114 domainOf (MkOpCatchUndef x) = domainOf x
115 domainOf (MkOpDefined x) = domainOf x
116 domainOf (MkOpDiv x) = domainOf x
117 domainOf (MkOpDontCare x) = domainOf x
118 domainOf (MkOpDotLeq x) = domainOf x
119 domainOf (MkOpDotLt x) = domainOf x
120 domainOf (MkOpEq x) = domainOf x
121 domainOf (MkOpFactorial x) = domainOf x
122 domainOf (MkOpFlatten x) = domainOf x
123 domainOf (MkOpFreq x) = domainOf x
124 domainOf (MkOpGCC x) = domainOf x
125 domainOf (MkOpGeq x) = domainOf x
126 domainOf (MkOpGt x) = domainOf x
127 domainOf (MkOpHist x) = domainOf x
128 domainOf (MkOpIff x) = domainOf x
129 domainOf (MkOpImage x) = domainOf x
130 domainOf (MkOpImageSet x) = domainOf x
131 domainOf (MkOpImply x) = domainOf x
132 domainOf (MkOpIn x) = domainOf x
133 domainOf (MkOpIndexing x) = domainOf x
134 domainOf (MkOpIntersect x) = domainOf x
135 domainOf (MkOpInverse x) = domainOf x
136 domainOf (MkOpLeq x) = domainOf x
137 domainOf (MkOpLexLeq x) = domainOf x
138 domainOf (MkOpLexLt x) = domainOf x
139 domainOf (MkOpLt x) = domainOf x
140 domainOf (MkOpMakeTable x) = domainOf x
141 domainOf (MkOpMax x) = domainOf x
142 domainOf (MkOpMin x) = domainOf x
143 domainOf (MkOpMinus x) = domainOf x
144 domainOf (MkOpMod x) = domainOf x
145 domainOf (MkOpNegate x) = domainOf x
146 domainOf (MkOpNeq x) = domainOf x
147 domainOf (MkOpNot x) = domainOf x
148 domainOf (MkOpOr x) = domainOf x
149 domainOf (MkOpParticipants x) = domainOf x
150 domainOf (MkOpParts x) = domainOf x
151 domainOf (MkOpParty x) = domainOf x
152 domainOf (MkOpPow x) = domainOf x
153 domainOf (MkOpPowerSet x) = domainOf x
154 domainOf (MkOpPred x) = domainOf x
155 domainOf (MkOpPreImage x) = domainOf x
156 domainOf (MkOpProduct x) = domainOf x
157 domainOf (MkOpRange x) = domainOf x
158 domainOf (MkOpRelationProj x) = domainOf x
159 domainOf (MkOpRestrict x) = domainOf x
160 domainOf (MkOpSlicing x) = domainOf x
161 domainOf (MkOpSubsequence x) = domainOf x
162 domainOf (MkOpSubset x) = domainOf x
163 domainOf (MkOpSubsetEq x) = domainOf x
164 domainOf (MkOpSubstring x) = domainOf x
165 domainOf (MkOpSucc x) = domainOf x
166 domainOf (MkOpSum x) = domainOf x
167 domainOf (MkOpSupset x) = domainOf x
168 domainOf (MkOpSupsetEq x) = domainOf x
169 domainOf (MkOpTable x) = domainOf x
170 domainOf (MkOpTildeLeq x) = domainOf x
171 domainOf (MkOpTildeLt x) = domainOf x
172 domainOf (MkOpTogether x) = domainOf x
173 domainOf (MkOpToInt x) = domainOf x
174 domainOf (MkOpToMSet x) = domainOf x
175 domainOf (MkOpToRelation x) = domainOf x
176 domainOf (MkOpToSet x) = domainOf x
177 domainOf (MkOpTransform x) = domainOf x
178 domainOf (MkOpTrue x) = domainOf x
179 domainOf (MkOpTwoBars x) = domainOf x
180 domainOf (MkOpUnion x) = domainOf x
181 domainOf (MkOpXor x) = domainOf x
182
183 indexDomainsOf (MkOpActive x) = indexDomainsOf x
184 indexDomainsOf (MkOpAllDiff x) = indexDomainsOf x
185 indexDomainsOf (MkOpAllDiffExcept x) = indexDomainsOf x
186 indexDomainsOf (MkOpAnd x) = indexDomainsOf x
187 indexDomainsOf (MkOpApart x) = indexDomainsOf x
188 indexDomainsOf (MkOpAtLeast x) = indexDomainsOf x
189 indexDomainsOf (MkOpAtMost x) = indexDomainsOf x
190 indexDomainsOf (MkOpAttributeAsConstraint x) = indexDomainsOf x
191 indexDomainsOf (MkOpCatchUndef x) = indexDomainsOf x
192 indexDomainsOf (MkOpDefined x) = indexDomainsOf x
193 indexDomainsOf (MkOpDiv x) = indexDomainsOf x
194 indexDomainsOf (MkOpDontCare x) = indexDomainsOf x
195 indexDomainsOf (MkOpDotLeq x) = indexDomainsOf x
196 indexDomainsOf (MkOpDotLt x) = indexDomainsOf x
197 indexDomainsOf (MkOpEq x) = indexDomainsOf x
198 indexDomainsOf (MkOpFactorial x) = indexDomainsOf x
199 indexDomainsOf (MkOpFlatten x) = indexDomainsOf x
200 indexDomainsOf (MkOpFreq x) = indexDomainsOf x
201 indexDomainsOf (MkOpGCC x) = indexDomainsOf x
202 indexDomainsOf (MkOpGeq x) = indexDomainsOf x
203 indexDomainsOf (MkOpGt x) = indexDomainsOf x
204 indexDomainsOf (MkOpHist x) = indexDomainsOf x
205 indexDomainsOf (MkOpIff x) = indexDomainsOf x
206 indexDomainsOf (MkOpImage x) = indexDomainsOf x
207 indexDomainsOf (MkOpImageSet x) = indexDomainsOf x
208 indexDomainsOf (MkOpImply x) = indexDomainsOf x
209 indexDomainsOf (MkOpIn x) = indexDomainsOf x
210 indexDomainsOf (MkOpIndexing x) = indexDomainsOf x
211 indexDomainsOf (MkOpIntersect x) = indexDomainsOf x
212 indexDomainsOf (MkOpInverse x) = indexDomainsOf x
213 indexDomainsOf (MkOpLeq x) = indexDomainsOf x
214 indexDomainsOf (MkOpLexLeq x) = indexDomainsOf x
215 indexDomainsOf (MkOpLexLt x) = indexDomainsOf x
216 indexDomainsOf (MkOpLt x) = indexDomainsOf x
217 indexDomainsOf (MkOpMakeTable x) = indexDomainsOf x
218 indexDomainsOf (MkOpMax x) = indexDomainsOf x
219 indexDomainsOf (MkOpMin x) = indexDomainsOf x
220 indexDomainsOf (MkOpMinus x) = indexDomainsOf x
221 indexDomainsOf (MkOpMod x) = indexDomainsOf x
222 indexDomainsOf (MkOpNegate x) = indexDomainsOf x
223 indexDomainsOf (MkOpNeq x) = indexDomainsOf x
224 indexDomainsOf (MkOpNot x) = indexDomainsOf x
225 indexDomainsOf (MkOpOr x) = indexDomainsOf x
226 indexDomainsOf (MkOpParticipants x) = indexDomainsOf x
227 indexDomainsOf (MkOpParts x) = indexDomainsOf x
228 indexDomainsOf (MkOpParty x) = indexDomainsOf x
229 indexDomainsOf (MkOpPow x) = indexDomainsOf x
230 indexDomainsOf (MkOpPowerSet x) = indexDomainsOf x
231 indexDomainsOf (MkOpPred x) = indexDomainsOf x
232 indexDomainsOf (MkOpPreImage x) = indexDomainsOf x
233 indexDomainsOf (MkOpProduct x) = indexDomainsOf x
234 indexDomainsOf (MkOpRange x) = indexDomainsOf x
235 indexDomainsOf (MkOpRelationProj x) = indexDomainsOf x
236 indexDomainsOf (MkOpRestrict x) = indexDomainsOf x
237 indexDomainsOf (MkOpSlicing x) = indexDomainsOf x
238 indexDomainsOf (MkOpSubsequence x) = indexDomainsOf x
239 indexDomainsOf (MkOpSubset x) = indexDomainsOf x
240 indexDomainsOf (MkOpSubsetEq x) = indexDomainsOf x
241 indexDomainsOf (MkOpSubstring x) = indexDomainsOf x
242 indexDomainsOf (MkOpSucc x) = indexDomainsOf x
243 indexDomainsOf (MkOpSum x) = indexDomainsOf x
244 indexDomainsOf (MkOpSupset x) = indexDomainsOf x
245 indexDomainsOf (MkOpSupsetEq x) = indexDomainsOf x
246 indexDomainsOf (MkOpTable x) = indexDomainsOf x
247 indexDomainsOf (MkOpTildeLeq x) = indexDomainsOf x
248 indexDomainsOf (MkOpTildeLt x) = indexDomainsOf x
249 indexDomainsOf (MkOpTogether x) = indexDomainsOf x
250 indexDomainsOf (MkOpToInt x) = indexDomainsOf x
251 indexDomainsOf (MkOpToMSet x) = indexDomainsOf x
252 indexDomainsOf (MkOpToRelation x) = indexDomainsOf x
253 indexDomainsOf (MkOpToSet x) = indexDomainsOf x
254 indexDomainsOf (MkOpTransform (OpTransform _ x)) = indexDomainsOf x
255 indexDomainsOf (MkOpTrue x) = indexDomainsOf x
256 indexDomainsOf (MkOpTwoBars x) = indexDomainsOf x
257 indexDomainsOf (MkOpUnion x) = indexDomainsOf x
258 indexDomainsOf (MkOpXor x) = indexDomainsOf x
259
260 instance DomainOf Constant where
261 domainOf ConstantBool{} = return DomainBool
262 domainOf i@(ConstantInt t _) = return $ DomainInt t [RangeSingle (Constant i)]
263 domainOf (ConstantEnum defn _ _ ) = return (DomainEnum defn Nothing Nothing)
264 domainOf ConstantField{} = failDoc "DomainOf-ConstantField"
265 domainOf (ConstantAbstract x) = domainOf (fmap Constant x)
266 domainOf (DomainInConstant dom) = return (fmap Constant dom)
267 domainOf (TypedConstant x ty) = domainOf (Typed (Constant x) ty)
268 domainOf ConstantUndefined{} = failDoc "DomainOf-ConstantUndefined"
269
270 indexDomainsOf ConstantBool{} = return []
271 indexDomainsOf ConstantInt{} = return []
272 indexDomainsOf ConstantEnum{} = return []
273 indexDomainsOf ConstantField{} = return []
274 indexDomainsOf (ConstantAbstract x) = indexDomainsOf (fmap Constant x)
275 indexDomainsOf DomainInConstant{} = return []
276 indexDomainsOf (TypedConstant x ty) = indexDomainsOf (Typed (Constant x) ty)
277 indexDomainsOf ConstantUndefined{} = return []
278
279 instance DomainOf (AbstractLiteral Expression) where
280
281 domainOf (AbsLitTuple xs) = DomainTuple <$> mapM domainOf xs
282
283 domainOf (AbsLitRecord xs) = DomainRecord <$> sequence [ do t <- domainOf x ; return (n,t)
284 | (n,x) <- xs ]
285
286 domainOf (AbsLitVariant Nothing _ _) = failDoc "Cannot calculate the domain of variant literal."
287 domainOf (AbsLitVariant (Just t) _ _) = return (DomainVariant t)
288
289 domainOf (AbsLitMatrix ind inn ) = DomainMatrix ind <$> (domainUnions =<< mapM domainOf inn)
290
291 domainOf (AbsLitSet [] ) = return $ DomainSet def attr (DomainAny "domainOf-AbsLitSet-[]" TypeAny)
292 where attr = SetAttr (SizeAttr_Size 0)
293 domainOf (AbsLitSet xs ) = DomainSet def attr <$> (domainUnions =<< mapM domainOf xs)
294 where attr = SetAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs)
295
296 domainOf (AbsLitMSet [] ) = return $ DomainMSet def attr (DomainAny "domainOf-AbsLitMSet-[]" TypeAny)
297 where attr = MSetAttr (SizeAttr_Size 0) OccurAttr_None
298 domainOf (AbsLitMSet xs ) = DomainMSet def attr <$> (domainUnions =<< mapM domainOf xs)
299 where attr = MSetAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs) OccurAttr_None
300
301 domainOf (AbsLitFunction [] ) = return $ DomainFunction def attr
302 (DomainAny "domainOf-AbsLitFunction-[]-1" TypeAny)
303 (DomainAny "domainOf-AbsLitFunction-[]-2" TypeAny)
304 where attr = FunctionAttr (SizeAttr_Size 0) def def
305 domainOf (AbsLitFunction xs ) = DomainFunction def attr
306 <$> (domainUnions =<< mapM (domainOf . fst) xs)
307 <*> (domainUnions =<< mapM (domainOf . snd) xs)
308 where attr = FunctionAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs) def def
309
310 domainOf (AbsLitSequence [] ) = return $ DomainSequence def attr
311 (DomainAny "domainOf-AbsLitSequence-[]" TypeAny)
312 where attr = SequenceAttr (SizeAttr_Size 0) def
313 domainOf (AbsLitSequence xs ) = DomainSequence def attr
314 <$> (domainUnions =<< mapM domainOf xs)
315 where attr = SequenceAttr (SizeAttr_MaxSize (fromInt $ genericLength xs)) def
316
317 domainOf (AbsLitRelation [] ) = return $ DomainRelation def attr []
318 where attr = RelationAttr (SizeAttr_Size 0) def
319 domainOf (AbsLitRelation xss) = do
320 ty <- domainUnions =<< mapM (domainOf . AbsLitTuple) xss
321 case ty of
322 DomainTuple ts -> return (DomainRelation def attr ts)
323 _ -> bug "expecting DomainTuple in domainOf"
324 where attr = RelationAttr (SizeAttr_MaxSize (fromInt $ genericLength xss)) def
325
326 domainOf (AbsLitPartition [] ) = return $ DomainPartition def attr
327 (DomainAny "domainOf-AbsLitPartition-[]" TypeAny)
328 where attr = PartitionAttr (SizeAttr_Size 0) (SizeAttr_Size 0) False
329 domainOf (AbsLitPartition xss) = DomainPartition def attr <$> (domainUnions =<< mapM domainOf (concat xss))
330 where attr = PartitionAttr (SizeAttr_MaxSize (fromInt $ genericLength xss))
331 (SizeAttr_MaxSize (fromInt $ maximum [genericLength xs | xs <- xss]))
332 False
333
334 indexDomainsOf (AbsLitMatrix ind inn) = (ind :) <$> (mapM domainUnions =<< mapM indexDomainsOf inn)
335 indexDomainsOf _ = return []
336
337
338
339 -- all the `Op`s
340
341 instance DomainOf (OpActive x) where
342 domainOf _ = return DomainBool
343
344 instance DomainOf (OpAllDiff x) where
345 domainOf _ = return DomainBool
346
347 instance DomainOf (OpAllDiffExcept x) where
348 domainOf _ = return DomainBool
349
350 instance DomainOf x => DomainOf (OpCatchUndef x) where
351 domainOf (OpCatchUndef x _) = domainOf x
352
353 instance DomainOf (OpAnd x) where
354 domainOf _ = return DomainBool
355
356 instance DomainOf (OpApart x) where
357 domainOf _ = return DomainBool
358
359 instance DomainOf (OpAttributeAsConstraint x) where
360 domainOf _ = return DomainBool
361
362 instance DomainOf x => DomainOf (OpDefined x) where
363 domainOf (OpDefined f) = do
364 fDom <- domainOf f
365 case fDom of
366 DomainFunction _ _ fr _ -> return $ DomainSet def def fr
367 _ -> failDoc "domainOf, OpDefined, not a function"
368
369 instance DomainOf x => DomainOf (OpDiv x) where
370 domainOf (OpDiv x y) = do
371 xDom :: Dom <- domainOf x
372 yDom :: Dom <- domainOf y
373 (iPat, i) <- quantifiedVar
374 (jPat, j) <- quantifiedVar
375 let vals = [essence| [ &i / &j
376 | &iPat : &xDom
377 , &jPat : &yDom
378 ] |]
379 let low = [essence| min(&vals) |]
380 let upp = [essence| max(&vals) |]
381 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
382
383 instance DomainOf (OpDontCare x) where
384 domainOf _ = return DomainBool
385
386 instance DomainOf (OpDotLeq x) where
387 domainOf _ = return DomainBool
388
389 instance DomainOf (OpDotLt x) where
390 domainOf _ = return DomainBool
391
392 instance DomainOf (OpEq x) where
393 domainOf _ = return DomainBool
394
395 instance (Pretty x, TypeOf x) => DomainOf (OpFactorial x) where
396 domainOf op = mkDomainAny ("OpFactorial:" <++> pretty op) <$> typeOf op
397
398 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpFlatten x) where
399 domainOf (OpFlatten (Just 1) x) = domainOf x >>= innerDomainOf
400 domainOf op = mkDomainAny ("OpFlatten:" <++> pretty op) <$> typeOf op
401
402 instance (Pretty x, TypeOf x) => DomainOf (OpFreq x) where
403 domainOf op = mkDomainAny ("OpFreq:" <++> pretty op) <$> typeOf op
404
405 instance DomainOf (OpGeq x) where
406 domainOf _ = return DomainBool
407
408 instance DomainOf (OpGt x) where
409 domainOf _ = return DomainBool
410
411 instance (Pretty x, TypeOf x) => DomainOf (OpHist x) where
412 domainOf op = mkDomainAny ("OpHist:" <++> pretty op) <$> typeOf op
413
414 instance DomainOf (OpIff x) where
415 domainOf _ = return DomainBool
416
417 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpImage x) where
418 domainOf (OpImage f _) = do
419 fDomain <- domainOf f
420 case fDomain of
421 DomainFunction _ _ _ to -> return to
422 DomainSequence _ _ to -> return to
423 _ -> failDoc "domainOf, OpImage, not a function or sequence"
424
425 instance (Pretty x, TypeOf x) => DomainOf (OpImageSet x) where
426 domainOf op = mkDomainAny ("OpImageSet:" <++> pretty op) <$> typeOf op
427
428 instance DomainOf (OpImply x) where
429 domainOf _ = return DomainBool
430
431 instance DomainOf (OpIn x) where
432 domainOf _ = return DomainBool
433
434 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x) => DomainOf (OpIndexing x) where
435 domainOf (OpIndexing m i) = do
436 iType <- typeOf i
437 case iType of
438 TypeBool{} -> return ()
439 TypeInt{} -> return ()
440 _ -> failDoc "domainOf, OpIndexing, not a bool or int index"
441 mDom <- domainOf m
442 case mDom of
443 DomainMatrix _ inner -> return inner
444 DomainTuple inners -> do
445 iInt <- intOut "domainOf OpIndexing" i
446 return $ atNote "domainOf" inners (fromInteger (iInt-1))
447 _ -> failDoc "domainOf, OpIndexing, not a matrix or tuple"
448
449 indexDomainsOf p@(OpIndexing m i) = do
450 iType <- typeOf i
451 case iType of
452 TypeBool{} -> return ()
453 TypeInt{} -> return ()
454 _ -> failDoc "domainOf, OpIndexing, not a bool or int index"
455 is <- indexDomainsOf m
456 case is of
457 [] -> failDoc ("indexDomainsOf{OpIndexing}, not a matrix domain:" <++> pretty p)
458 (_:is') -> return is'
459
460 instance (Pretty x, TypeOf x) => DomainOf (OpIntersect x) where
461 domainOf op = mkDomainAny ("OpIntersect:" <++> pretty op) <$> typeOf op
462
463 instance DomainOf (OpInverse x) where
464 domainOf _ = return DomainBool
465
466 instance DomainOf (OpLeq x) where
467 domainOf _ = return DomainBool
468
469 instance DomainOf (OpLexLeq x) where
470 domainOf _ = return DomainBool
471
472 instance DomainOf (OpLexLt x) where
473 domainOf _ = return DomainBool
474
475 instance DomainOf (OpLt x) where
476 domainOf _ = return DomainBool
477
478 instance DomainOf (OpMakeTable x) where
479 domainOf _ = return DomainBool
480
481 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x, Domain () x :< x) => DomainOf (OpMax x) where
482 domainOf (OpMax x)
483 | Just xs <- listOut x
484 , not (null xs) = do
485 doms <- mapM domainOf xs
486 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
487 let low = [essence| max(&lows) |]
488 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
489 let upp = [essence| max(&upps) |]
490 TypeInt t <- typeOfDomain (head doms)
491 return (DomainInt t [RangeBounded low upp] :: Dom)
492 domainOf op = mkDomainAny ("OpMax:" <++> pretty op) <$> typeOf op
493
494 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x, Domain () x :< x) => DomainOf (OpMin x) where
495 domainOf (OpMin x)
496 | Just xs <- listOut x
497 , not (null xs) = do
498 doms <- mapM domainOf xs
499 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
500 let low = [essence| min(&lows) |]
501 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
502 let upp = [essence| min(&upps) |]
503 TypeInt t <- typeOfDomain (head doms)
504 return (DomainInt t [RangeBounded low upp] :: Dom)
505 domainOf op = mkDomainAny ("OpMin:" <++> pretty op) <$> typeOf op
506
507 instance DomainOf x => DomainOf (OpMinus x) where
508 domainOf (OpMinus x y) = do
509 xDom :: Dom <- domainOf x
510 yDom :: Dom <- domainOf y
511
512 xDom_Min <- minOfDomain xDom
513 xDom_Max <- maxOfDomain xDom
514 yDom_Min <- minOfDomain yDom
515 yDom_Max <- maxOfDomain yDom
516
517 let low = [essence| &xDom_Min - &yDom_Max |]
518 let upp = [essence| &xDom_Max - &yDom_Min |]
519
520 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
521
522 instance (Pretty x, TypeOf x) => DomainOf (OpMod x) where
523 domainOf op = mkDomainAny ("OpMod:" <++> pretty op) <$> typeOf op
524
525 instance (Pretty x, TypeOf x) => DomainOf (OpNegate x) where
526 domainOf op = mkDomainAny ("OpNegate:" <++> pretty op) <$> typeOf op
527
528 instance DomainOf (OpNeq x) where
529 domainOf _ = return DomainBool
530
531 instance DomainOf (OpNot x) where
532 domainOf _ = return DomainBool
533
534 instance DomainOf (OpOr x) where
535 domainOf _ = return DomainBool
536
537 instance DomainOf (OpXor x) where
538 domainOf _ = return DomainBool
539
540 instance (Pretty x, TypeOf x) => DomainOf (OpParticipants x) where
541 domainOf op = mkDomainAny ("OpParticipants:" <++> pretty op) <$> typeOf op
542
543 instance DomainOf x => DomainOf (OpParts x) where
544 domainOf (OpParts p) = do
545 dom <- domainOf p
546 case dom of
547 DomainPartition _ _ inner -> return $ DomainSet def def $ DomainSet def def inner
548 _ -> failDoc "domainOf, OpParts, not a partition"
549
550 instance (Pretty x, TypeOf x) => DomainOf (OpParty x) where
551 domainOf op = mkDomainAny ("OpParty:" <++> pretty op) <$> typeOf op
552
553 instance (Pretty x, TypeOf x) => DomainOf (OpPow x) where
554 domainOf op = mkDomainAny ("OpPow:" <++> pretty op) <$> typeOf op
555
556 instance (Pretty x, TypeOf x) => DomainOf (OpPowerSet x) where
557 domainOf op = mkDomainAny ("OpPowerSet:" <++> pretty op) <$> typeOf op
558
559 instance (Pretty x, TypeOf x) => DomainOf (OpPreImage x) where
560 domainOf op = mkDomainAny ("OpPreImage:" <++> pretty op) <$> typeOf op
561
562 instance DomainOf x => DomainOf (OpPred x) where
563 domainOf (OpPred x) = domainOf x -- TODO: improve
564
565 instance (ExpressionLike x, DomainOf x) => DomainOf (OpProduct x) where
566 domainOf (OpProduct x)
567 | Just xs <- listOut x
568 , not (null xs) = do
569 (iPat, i) <- quantifiedVar
570 doms <- mapM domainOf xs
571 -- maximum absolute value in each domain
572 let upps = fromList [ [essence| max([ |&i| | &iPat : &d ]) |]
573 | d <- doms ]
574 -- a (too lax) upper bound is multiplying all those together
575 let upp = [essence| product(&upps) |]
576 -- a (too lax) lower bound is -upp
577 let low = [essence| -1 * &upp |]
578 return $ DomainInt TagInt [RangeBounded low upp]
579 domainOf _ = return $ DomainInt TagInt [RangeBounded 1 1]
580
581 instance DomainOf x => DomainOf (OpRange x) where
582 domainOf (OpRange f) = do
583 fDom <- domainOf f
584 case fDom of
585 DomainFunction _ _ _ to -> return $ DomainSet def def to
586 _ -> failDoc "domainOf, OpRange, not a function"
587
588 instance (Pretty x, TypeOf x) => DomainOf (OpRelationProj x) where
589 domainOf op = mkDomainAny ("OpRelationProj:" <++> pretty op) <$> typeOf op
590
591 instance (DomainOf x, Dom :< x) => DomainOf (OpRestrict x) where
592 domainOf (OpRestrict f x) = do
593 d <- project x
594 fDom <- domainOf f
595 case fDom of
596 DomainFunction fRepr a _ to -> return (DomainFunction fRepr a d to)
597 _ -> failDoc "domainOf, OpRestrict, not a function"
598
599 instance (Pretty x, DomainOf x) => DomainOf (OpSlicing x) where
600 domainOf (OpSlicing x _ _) = domainOf x
601 indexDomainsOf (OpSlicing x _ _) = indexDomainsOf x
602
603 instance DomainOf (OpSubsequence x) where
604 domainOf _ = failDoc "domainOf{OpSubsequence}"
605
606 instance (Pretty x, TypeOf x) => DomainOf (OpSubset x) where
607 domainOf op = mkDomainAny ("OpSubset:" <++> pretty op) <$> typeOf op
608
609 instance (Pretty x, TypeOf x) => DomainOf (OpSubsetEq x) where
610 domainOf op = mkDomainAny ("OpSubsetEq:" <++> pretty op) <$> typeOf op
611
612 instance DomainOf (OpSubstring x) where
613 domainOf _ = failDoc "domainOf{OpSubstring}"
614
615 instance DomainOf x => DomainOf (OpSucc x) where
616 domainOf (OpSucc x) = domainOf x -- TODO: improve
617
618 instance (ExpressionLike x, DomainOf x) => DomainOf (OpSum x) where
619 domainOf (OpSum x)
620 | Just xs <- listOut x
621 , not (null xs) = do
622 doms <- mapM domainOf xs
623 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
624 let low = [essence| sum(&lows) |]
625 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
626 let upp = [essence| sum(&upps) |]
627 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
628 domainOf _ = return $ DomainInt TagInt [RangeBounded 0 0]
629
630
631 instance DomainOf (OpSupset x) where
632 domainOf _ = return DomainBool
633
634 instance DomainOf (OpSupsetEq x) where
635 domainOf _ = return DomainBool
636
637 instance DomainOf (OpTable x) where
638 domainOf _ = return DomainBool
639
640 instance DomainOf (OpAtLeast x) where
641 domainOf _ = return DomainBool
642
643 instance DomainOf (OpAtMost x) where
644 domainOf _ = return DomainBool
645
646 instance DomainOf (OpGCC x) where
647 domainOf _ = return DomainBool
648
649 instance DomainOf (OpTildeLeq x) where
650 domainOf _ = return DomainBool
651
652 instance DomainOf (OpTildeLt x) where
653 domainOf _ = return DomainBool
654
655 instance DomainOf (OpToInt x) where
656 domainOf _ = return $ DomainInt TagInt [RangeBounded 0 1]
657
658 instance (Pretty x, TypeOf x) => DomainOf (OpToMSet x) where
659 domainOf op = mkDomainAny ("OpToMSet:" <++> pretty op) <$> typeOf op
660
661 instance (Pretty x, TypeOf x) => DomainOf (OpToRelation x) where
662 domainOf op = mkDomainAny ("OpToRelation:" <++> pretty op) <$> typeOf op
663
664 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpToSet x) where
665 domainOf (OpToSet _ x) = do
666 domX <- domainOf x
667 innerDomX <- innerDomainOf domX
668 return $ DomainSet () def innerDomX
669
670 instance DomainOf (OpTogether x) where
671 domainOf _ = return DomainBool
672
673 instance (Pretty x, TypeOf x) => DomainOf (OpTransform x) where
674 domainOf op = mkDomainAny ("OpTransform:" <++> pretty op) <$> typeOf op
675
676 instance DomainOf (OpTrue x) where
677 domainOf _ = return DomainBool
678
679 instance (Pretty x, TypeOf x, Domain () x :< x) => DomainOf (OpTwoBars x) where
680 domainOf op = mkDomainAny ("OpTwoBars:" <++> pretty op) <$> typeOf op
681
682 instance (Pretty x, TypeOf x) => DomainOf (OpUnion x) where
683 domainOf op = mkDomainAny ("OpUnion:" <++> pretty op) <$> typeOf op
684