never executed always true always false
1 {-# LANGUAGE TupleSections #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 {-# LANGUAGE NoMonomorphismRestriction #-}
4
5 module Conjure.Compute.DomainUnion
6 ( domainUnion,
7 domainUnions,
8 )
9 where
10
11 -- conjure
12
13 import Conjure.Bug
14 import Conjure.Language.AdHoc
15 import Conjure.Language.Domain
16 import Conjure.Language.Expression.Op
17 import Conjure.Language.Lenses
18 import Conjure.Language.Name
19 import Conjure.Language.Pretty
20 import Conjure.Language.Type
21 import Conjure.Prelude
22 import Data.List as L (union)
23 -- containers
24 import Data.Set as S (union)
25
26 class DomainUnion a where
27 domainUnion :: (Applicative m, Monad m) => a -> a -> m a
28
29 domainUnions ::
30 ( Applicative m,
31 Monad m,
32 Pretty r,
33 Default r,
34 Eq x,
35 Pretty x,
36 ExpressionLike x,
37 Op x :< x
38 ) =>
39 [Domain r x] ->
40 m (Domain r x)
41 domainUnions [] = return $ DomainAny "domainUnions []" TypeAny
42 domainUnions [a] = return a
43 domainUnions (a : as) = do b <- domainUnions as; domainUnion a b
44
45 instance
46 ( Eq x,
47 ExpressionLike x,
48 Op x :< x,
49 Pretty x,
50 Pretty r,
51 Default r
52 ) =>
53 DomainUnion (Domain r x)
54 where
55 domainUnion d@(DomainReference nm1 _) (DomainReference nm2 _) | nm1 == nm2 = return d
56 domainUnion d@(DomainInt (TagUnnamed nm1) _) (DomainReference (Name nm2) _) | nm1 == nm2 = return d
57 domainUnion (DomainReference (Name nm2) _) d@(DomainInt (TagUnnamed nm1) _) | nm1 == nm2 = return d
58 domainUnion DomainAny {} d = return d
59 domainUnion d DomainAny {} = return d
60 domainUnion DomainBool DomainBool = return DomainBool
61 domainUnion (DomainInt t r1) (DomainInt _ r2) =
62 return $ DomainInt t (r1 `L.union` r2)
63 domainUnion (DomainTuple []) d@DomainTuple {} = return d
64 domainUnion d@DomainTuple {} (DomainTuple []) = return d
65 domainUnion (DomainTuple xs) (DomainTuple ys)
66 | length xs == length ys =
67 DomainTuple <$> zipWithM domainUnion xs ys
68 domainUnion d1@(DomainRecord xs) d2@(DomainRecord ys)
69 | length xs == length ys =
70 DomainRecord
71 <$> sequence
72 [ case mdomY of
73 Just domY -> do
74 domZ <- domainUnion domX domY
75 return (nm, domZ)
76 Nothing -> bug $ vcat ["Domain.domainUnion", pretty d1, pretty d2]
77 | (nm, domX) <- xs,
78 let mdomY = lookup nm ys
79 ]
80 domainUnion (DomainMatrix x1 x2) (DomainMatrix y1 y2) =
81 DomainMatrix <$> domainUnion x1 y1 <*> domainUnion x2 y2
82 domainUnion (DomainSet _ xA x) (DomainSet _ yA y) =
83 DomainSet def <$> domainUnion xA yA <*> domainUnion x y
84 domainUnion (DomainMSet _ xA x) (DomainMSet _ yA y) =
85 DomainMSet def <$> domainUnion xA yA <*> domainUnion x y
86 domainUnion (DomainFunction _ xA x1 x2) (DomainFunction _ yA y1 y2) =
87 DomainFunction def <$> domainUnion xA yA <*> domainUnion x1 y1 <*> domainUnion x2 y2
88 domainUnion (DomainSequence _ xA x) (DomainSequence _ yA y) =
89 DomainSequence def <$> domainUnion xA yA <*> domainUnion x y
90 domainUnion (DomainRelation _ _ []) d@DomainRelation {} = return d
91 domainUnion d@DomainRelation {} (DomainRelation _ _ []) = return d
92 domainUnion (DomainRelation _ xA xs) (DomainRelation _ yA ys)
93 | length xs == length ys =
94 DomainRelation def <$> domainUnion xA yA <*> zipWithM domainUnion xs ys
95 domainUnion (DomainPartition _ xA x) (DomainPartition _ yA y) =
96 DomainPartition def <$> domainUnion xA yA <*> domainUnion x y
97 domainUnion (DomainPermutation _ xA x) (DomainPermutation _ yA y) =
98 DomainPermutation def <$> domainUnion xA yA <*> domainUnion x y
99 domainUnion d1 d2 = bug $ vcat ["Domain.domainUnion", pretty (show d1), pretty (show d2)]
100
101 instance
102 ( ExpressionLike x,
103 Op x :< x,
104 Pretty x
105 ) =>
106 DomainUnion (SetAttr x)
107 where
108 domainUnion (SetAttr a) (SetAttr b) = SetAttr <$> domainUnion a b
109
110 instance
111 ( ExpressionLike x,
112 Op x :< x,
113 Pretty x,
114 Eq x
115 ) =>
116 DomainUnion (PermutationAttr x)
117 where
118 domainUnion (PermutationAttr a) (PermutationAttr b)
119 | a == b = return (PermutationAttr a)
120 | otherwise = bug "DomainUnion PermutationAttr"
121
122 instance
123 ( ExpressionLike x,
124 Op x :< x,
125 Pretty x
126 ) =>
127 DomainUnion (SizeAttr x)
128 where
129 domainUnion SizeAttr_None s = return s
130 domainUnion s SizeAttr_None = return s
131 domainUnion a b =
132 return
133 $ SizeAttr_MinMaxSize
134 (make opMin (fromList [minA, minB]))
135 (make opMax (fromList [maxA, maxB]))
136 where
137 (minA, maxA) = getMinMax a
138 (minB, maxB) = getMinMax b
139 getMinMax p = case p of
140 SizeAttr_None -> bug "Monoid SizeAttr"
141 SizeAttr_Size x -> (x, x)
142 SizeAttr_MinSize x -> (x, x)
143 SizeAttr_MaxSize x -> (x, x)
144 SizeAttr_MinMaxSize x y -> (x, y)
145
146 instance
147 ( ExpressionLike x,
148 Op x :< x,
149 Pretty x
150 ) =>
151 DomainUnion (MSetAttr x)
152 where
153 domainUnion (MSetAttr a1 a2) (MSetAttr b1 b2) = MSetAttr <$> domainUnion a1 b1 <*> domainUnion a2 b2
154
155 instance
156 ( ExpressionLike x,
157 Op x :< x,
158 Pretty x
159 ) =>
160 DomainUnion (OccurAttr x)
161 where
162 domainUnion OccurAttr_None s = return s
163 domainUnion s OccurAttr_None = return s
164 domainUnion a b =
165 return
166 $ OccurAttr_MinMaxOccur
167 (make opMin (fromList [minA, minB]))
168 (make opMax (fromList [maxA, maxB]))
169 where
170 (minA, maxA) = getMinMax a
171 (minB, maxB) = getMinMax b
172 getMinMax p = case p of
173 OccurAttr_None -> bug "Monoid OccurAttr"
174 OccurAttr_MinOccur x -> (x, x)
175 OccurAttr_MaxOccur x -> (x, x)
176 OccurAttr_MinMaxOccur x y -> (x, y)
177
178 instance
179 ( ExpressionLike x,
180 Op x :< x,
181 Pretty x
182 ) =>
183 DomainUnion (FunctionAttr x)
184 where
185 domainUnion (FunctionAttr a1 a2 a3) (FunctionAttr b1 b2 b3) =
186 FunctionAttr <$> domainUnion a1 b1 <*> domainUnion a2 b2 <*> domainUnion a3 b3
187
188 instance DomainUnion PartialityAttr where
189 domainUnion PartialityAttr_Partial _ = return PartialityAttr_Partial
190 domainUnion _ PartialityAttr_Partial = return PartialityAttr_Partial
191 domainUnion PartialityAttr_Total PartialityAttr_Total = return PartialityAttr_Total
192
193 instance DomainUnion JectivityAttr where
194 domainUnion x y | x == y = return x
195 domainUnion _ _ = return JectivityAttr_None
196
197 instance
198 ( ExpressionLike x,
199 Op x :< x,
200 Pretty x
201 ) =>
202 DomainUnion (SequenceAttr x)
203 where
204 domainUnion (SequenceAttr a1 a2) (SequenceAttr b1 b2) =
205 SequenceAttr <$> domainUnion a1 b1 <*> domainUnion a2 b2
206
207 instance
208 ( ExpressionLike x,
209 Op x :< x,
210 Pretty x
211 ) =>
212 DomainUnion (RelationAttr x)
213 where
214 domainUnion (RelationAttr a1 a2) (RelationAttr b1 b2) =
215 RelationAttr <$> domainUnion a1 b1 <*> domainUnion a2 b2
216
217 instance DomainUnion BinaryRelationAttrs where
218 domainUnion (BinaryRelationAttrs a) (BinaryRelationAttrs b) =
219 return $ BinaryRelationAttrs (S.union a b)
220
221 instance
222 ( ExpressionLike x,
223 Op x :< x,
224 Pretty x
225 ) =>
226 DomainUnion (PartitionAttr x)
227 where
228 domainUnion (PartitionAttr a1 a2 a3) (PartitionAttr b1 b2 b3) =
229 PartitionAttr <$> domainUnion a1 b1 <*> domainUnion a2 b2 <*> pure (a3 || b3)