never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2
3 module Conjure.Rules.Vertical.Tuple where
4
5 import Conjure.Rules.Import
6
7
8 rule_Tuple_Eq :: Rule
9 rule_Tuple_Eq = "tuple-eq" `namedRule` theRule where
10 theRule p = do
11 (x,y) <- match opEq p
12 TypeTuple{} <- typeOf x -- TODO: check if x and y have the same arity
13 TypeTuple{} <- typeOf y
14 xs <- downX1 x
15 ys <- downX1 y
16 return
17 ( "Horizontal rule for tuple equality"
18 , return $ make opAnd $ fromList $ zipWith (make opEq) xs ys
19 )
20
21
22 rule_Tuple_Neq :: Rule
23 rule_Tuple_Neq = "tuple-neq" `namedRule` theRule where
24 theRule p = do
25 (x,y) <- match opNeq p
26 TypeTuple{} <- typeOf x -- TODO: check if x and y have the same arity
27 TypeTuple{} <- typeOf y
28 xs <- downX1 x
29 ys <- downX1 y
30 return
31 ( "Horizontal rule for tuple !="
32 , return $ make opNot $ make opAnd $ fromList $ zipWith (make opEq) xs ys
33 )
34
35
36 rule_Tuple_Lt :: Rule
37 rule_Tuple_Lt = "tuple-Lt" `namedRule` theRule where
38 theRule p = do
39 (x,y) <- match opLt p
40 TypeTuple{} <- typeOf x -- TODO: check if x and y have the same arity
41 TypeTuple{} <- typeOf y
42 xs <- downX1 x
43 ys <- downX1 y
44 return
45 ( "Horizontal rule for tuple <"
46 , return $ decomposeLexLt p xs ys
47 )
48
49
50 rule_Tuple_Leq :: Rule
51 rule_Tuple_Leq = "tuple-Leq" `namedRule` theRule where
52 theRule p = do
53 (x,y) <- match opLeq p
54 TypeTuple{} <- typeOf x -- TODO: check if x and y have the same arity
55 TypeTuple{} <- typeOf y
56 xs <- downX1 x
57 ys <- downX1 y
58 return
59 ( "Horizontal rule for tuple <="
60 , return $ decomposeLexLeq p xs ys
61 )
62
63
64 rule_Tuple_TildeLt :: Rule
65 rule_Tuple_TildeLt = "tuple-TildeLt" `namedRule` theRule where
66 theRule p = do
67 (x,y) <- match opTildeLt p
68 TypeTuple{} <- typeOf x -- TODO: check if x and y have the same arity
69 TypeTuple{} <- typeOf y
70 xs <- downX1 x
71 ys <- downX1 y
72 return
73 ( "Horizontal rule for tuple ~<"
74 , return $ decomposeLexTildeLt p xs ys
75 )
76
77
78 rule_Tuple_TildeLeq :: Rule
79 rule_Tuple_TildeLeq = "tuple-TildeLeq" `namedRule` theRule where
80 theRule p = do
81 (x,y) <- match opTildeLeq p
82 TypeTuple{} <- typeOf x -- TODO: check if x and y have the same arity
83 TypeTuple{} <- typeOf y
84 xs <- downX1 x
85 ys <- downX1 y
86 return
87 ( "Horizontal rule for tuple ~<="
88 , return $ decomposeLexTildeLeq p xs ys
89 )
90
91
92 -- .<= that contains a trainsform in it cannot be handled by the general symmetryOrdering-based rule
93 rule_Tuple_DotLeq :: Rule
94 rule_Tuple_DotLeq = "tuple-DotLeq" `namedRule` theRule where
95 theRule p = do
96 (x,y) <- match opDotLeq p
97 TypeTuple{} <- typeOf x -- TODO: check if x and y have the same arity
98 TypeTuple{} <- typeOf y
99 let containsTransform = [ () | Op (MkOpTransform{}) <- universe p ]
100 when (null containsTransform) $ na "rule_Tuple_DotLeq"
101 xs <- downX1 x
102 ys <- downX1 y
103 return
104 ( "Horizontal rule for tuple .<="
105 , return $ decomposeLexDotLeq p xs ys
106 )
107
108
109 decomposeLexLexLt :: Expression -> [Expression] -> [Expression] -> Expression
110 decomposeLexLexLt p = unroll
111 where
112 unroll [a] [b] = [essence| &a <lex &b |]
113 unroll (a:as) (b:bs) = let rest = unroll as bs
114 in [essence| (&a <lex &b) /\ &rest |]
115 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
116
117 decomposeLexLexLeq :: Expression -> [Expression] -> [Expression] -> Expression
118 decomposeLexLexLeq p = unroll
119 where
120 unroll [a] [b] = [essence| &a <=lex &b |]
121 unroll (a:as) (b:bs) = let rest = unroll as bs
122 in [essence| (&a <=lex &b) /\ &rest |]
123 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
124
125
126
127 decomposeLexLt :: Expression -> [Expression] -> [Expression] -> Expression
128 decomposeLexLt p = unroll
129 where
130 unroll [a] [b] = [essence| &a < &b |]
131 unroll (a:as) (b:bs) = let rest = unroll as bs
132 in [essence| (&a < &b) \/ ((&a = &b) /\ &rest) |]
133 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
134
135 decomposeLexLeq :: Expression -> [Expression] -> [Expression] -> Expression
136 decomposeLexLeq p = unroll
137 where
138 unroll [a] [b] = [essence| &a <= &b |]
139 unroll (a:as) (b:bs) = let rest = unroll as bs
140 in [essence| (&a < &b) \/ ((&a = &b) /\ &rest) |]
141 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
142
143
144 decomposeLexDotLt :: Expression -> [Expression] -> [Expression] -> Expression
145 decomposeLexDotLt p = unroll
146 where
147 unroll [a] [b] = [essence| &a .< &b |]
148 unroll (a:as) (b:bs) = let rest = unroll as bs
149 in [essence| (&a .< &b) \/ ((&a = &b) /\ &rest) |]
150 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
151
152 decomposeLexDotLeq :: Expression -> [Expression] -> [Expression] -> Expression
153 decomposeLexDotLeq p = unroll
154 where
155 unroll [a] [b] = [essence| &a .<= &b |]
156 unroll (a:as) (b:bs) = let rest = unroll as bs
157 in [essence| (&a .< &b) \/ ((&a = &b) /\ &rest) |]
158 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
159
160
161 decomposeLexTildeLt :: Expression -> [Expression] -> [Expression] -> Expression
162 decomposeLexTildeLt p = unroll
163 where
164 unroll [a] [b] = [essence| &a ~< &b |]
165 unroll (a:as) (b:bs) = let rest = unroll as bs
166 in [essence| (&a ~< &b) \/ ((&a = &b) /\ &rest) |]
167 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
168
169 decomposeLexTildeLeq :: Expression -> [Expression] -> [Expression] -> Expression
170 decomposeLexTildeLeq p = unroll
171 where
172 unroll [a] [b] = [essence| &a ~<= &b |]
173 unroll (a:as) (b:bs) = let rest = unroll as bs
174 in [essence| (&a ~< &b) \/ ((&a = &b) /\ &rest) |]
175 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
176
177
178 rule_Tuple_Index :: Rule
179 rule_Tuple_Index = "tuple-index" `namedRule` theRule where
180 theRule p = do
181 (t,i) <- match opIndexing p
182 TypeTuple{} <- typeOf t
183 iInt <- match constantInt i
184 ts <- downX1 t
185 return
186 ( "Tuple indexing on:" <+> pretty p
187 , return $ atNote "Tuple indexing" ts (fromInteger (iInt-1))
188 )