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