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 decomposeLexLt :: Expression -> [Expression] -> [Expression] -> Expression
93 decomposeLexLt p = unroll
94 where
95 unroll [a] [b] = [essence| &a < &b |]
96 unroll (a:as) (b:bs) = let rest = unroll as bs
97 in [essence| (&a < &b) \/ ((&a = &b) /\ &rest) |]
98 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
99
100 decomposeLexLeq :: Expression -> [Expression] -> [Expression] -> Expression
101 decomposeLexLeq p = unroll
102 where
103 unroll [a] [b] = [essence| &a <= &b |]
104 unroll (a:as) (b:bs) = let rest = unroll as bs
105 in [essence| (&a < &b) \/ ((&a = &b) /\ &rest) |]
106 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
107
108
109 decomposeLexDotLt :: Expression -> [Expression] -> [Expression] -> Expression
110 decomposeLexDotLt p = unroll
111 where
112 unroll [a] [b] = [essence| &a .< &b |]
113 unroll (a:as) (b:bs) = let rest = unroll as bs
114 in [essence| (&a .< &b) \/ ((&a = &b) /\ &rest) |]
115 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
116
117 decomposeLexDotLeq :: Expression -> [Expression] -> [Expression] -> Expression
118 decomposeLexDotLeq p = unroll
119 where
120 unroll [a] [b] = [essence| &a .<= &b |]
121 unroll (a:as) (b:bs) = let rest = unroll as bs
122 in [essence| (&a .< &b) \/ ((&a = &b) /\ &rest) |]
123 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
124
125
126 decomposeLexTildeLt :: Expression -> [Expression] -> [Expression] -> Expression
127 decomposeLexTildeLt p = unroll
128 where
129 unroll [a] [b] = [essence| &a ~< &b |]
130 unroll (a:as) (b:bs) = let rest = unroll as bs
131 in [essence| (&a ~< &b) \/ ((&a = &b) /\ &rest) |]
132 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
133
134 decomposeLexTildeLeq :: Expression -> [Expression] -> [Expression] -> Expression
135 decomposeLexTildeLeq p = unroll
136 where
137 unroll [a] [b] = [essence| &a ~<= &b |]
138 unroll (a:as) (b:bs) = let rest = unroll as bs
139 in [essence| (&a ~< &b) \/ ((&a = &b) /\ &rest) |]
140 unroll _ _ = bug ("arity mismatch in:" <+> pretty p)
141
142
143 rule_Tuple_Index :: Rule
144 rule_Tuple_Index = "tuple-index" `namedRule` theRule where
145 theRule p = do
146 (t,i) <- match opIndexing p
147 TypeTuple{} <- typeOf t
148 iInt <- match constantInt i
149 ts <- downX1 t
150 return
151 ( "Tuple indexing on:" <+> pretty p
152 , return $ atNote "Tuple indexing" ts (fromInteger (iInt-1))
153 )