never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2
3 module Conjure.Rules.Vertical.Variant where
4
5 import Conjure.Rules.Import
6
7
8 rule_Variant_Eq :: Rule
9 rule_Variant_Eq = "variant-eq" `namedRule` theRule where
10 theRule p = do
11 (x,y) <- match opEq p
12 TypeVariant{} <- typeOf x -- TODO: check if x and y have the same arity
13 TypeVariant{} <- typeOf y
14 (xWhich:xs) <- downX1 x
15 (yWhich:ys) <- downX1 y
16 return
17 ( "Horizontal rule for variant equality"
18 , return $ make opAnd $ fromList
19 [ [essence| &xWhich = &yWhich |] -- the tags are eq
20 , onTagged (make opEq) xWhich xs ys -- and the tagged values are eq
21 ]
22 )
23
24
25 rule_Variant_Neq :: Rule
26 rule_Variant_Neq = "variant-neq" `namedRule` theRule where
27 theRule p = do
28 (x,y) <- match opNeq p
29 TypeVariant{} <- typeOf x -- TODO: check if x and y have the same arity
30 TypeVariant{} <- typeOf y
31 (xWhich:xs) <- downX1 x
32 (yWhich:ys) <- downX1 y
33 return
34 ( "Horizontal rule for variant !="
35 , return $ make opOr $ fromList
36 [ [essence| &xWhich != &yWhich |] -- either the tags are diff
37 , make opAnd $ fromList
38 [ [essence| &xWhich = &yWhich |] -- or the tags are eq
39 , onTagged (make opNeq) xWhich xs ys -- and the tagged values are diff
40 ]
41 ]
42 )
43
44
45 rule_Variant_Lt :: Rule
46 rule_Variant_Lt = "variant-Lt" `namedRule` theRule where
47 theRule p = do
48 (x,y) <- match opLt p
49 TypeVariant{} <- typeOf x -- TODO: check if x and y have the same arity
50 TypeVariant{} <- typeOf y
51 (xWhich:xs) <- downX1 x
52 (yWhich:ys) <- downX1 y
53 return
54 ( "Horizontal rule for variant <"
55 , return $ make opOr $ fromList
56 [ [essence| &xWhich < &yWhich |] -- either the tags are <
57 , make opAnd $ fromList
58 [ [essence| &xWhich = &yWhich |] -- or the tags are eq
59 , onTagged (make opLt) xWhich xs ys -- and the tagged values are <
60 ]
61 ]
62 )
63
64
65 rule_Variant_Leq :: Rule
66 rule_Variant_Leq = "variant-Leq" `namedRule` theRule where
67 theRule p = do
68 (x,y) <- match opLeq p
69 TypeVariant{} <- typeOf x -- TODO: check if x and y have the same arity
70 TypeVariant{} <- typeOf y
71 (xWhich:xs) <- downX1 x
72 (yWhich:ys) <- downX1 y
73 return
74 ( "Horizontal rule for variant <="
75 , return $ make opOr $ fromList
76 [ [essence| &xWhich < &yWhich |] -- either the tags are <
77 , make opAnd $ fromList
78 [ [essence| &xWhich = &yWhich |] -- or the tags are eq
79 , onTagged (make opLeq) xWhich xs ys -- and the tagged values are <=
80 ]
81 ]
82 )
83
84
85 rule_Variant_Index :: Rule
86 rule_Variant_Index = "variant-index" `namedRule` theRule where
87 theRule p = do
88 (x,arg) <- match opIndexing p
89 TypeVariant ds <- typeOf x
90 (xWhich:xs) <- downX1 x
91 name <- nameOut arg
92 argInt <- case elemIndex name (map fst ds) of
93 Nothing -> failDoc "Variant indexing, not a member of the type."
94 Just argInt -> return argInt
95 return
96 ( "Variant indexing on:" <+> pretty p
97 , return $ WithLocals
98 (atNote "Variant indexing" xs argInt) -- the value is projected
99 (DefinednessConstraints
100 [ [essence| &xWhich = &argInt2 |] -- the tag is equal to i
101 | let argInt2 = fromInt (fromIntegral (argInt + 1))
102 ])
103 )
104
105
106 rule_Variant_Active :: Rule
107 rule_Variant_Active = "variant-active" `namedRule` theRule where
108 theRule p = do
109 (x,name) <- match opActive p
110 TypeVariant ds <- typeOf x
111 (xWhich:_) <- downX1 x
112 argInt <- case elemIndex name (map fst ds) of
113 Nothing -> failDoc "Variant indexing, not a member of the type."
114 Just argInt -> return $ fromInt $ fromIntegral $ argInt + 1
115 return
116 ( "Variant active on:" <+> pretty p
117 , return $ [essence| &xWhich = &argInt |]
118 )
119
120
121 -- | puts a constraint on the pair of tagged values
122 -- NOTICE: you might want to check if the tags are same before calling this!
123 onTagged
124 :: (Expression -> Expression -> Expression) -- the constraint generator
125 -> Expression -- tag
126 -> [Expression] -- first bunch of options
127 -> [Expression] -- second bunch of options
128 -> Expression -- the constraint
129 onTagged f which xs ys = make opAnd $ fromList
130 [ [essence| &i = &which -> &cons |] -- and the tagged values are eq
131 | (i',x,y) <- zip3 [1..] xs ys
132 , let i = fromInt i'
133 , let cons = f x y
134 , let zero = ExpressionMetaVar "zeroVal for variant"
135 , x /= zero
136 , y /= zero
137 ]