Complete work on new OVERLAPPABLE/OVERLAPPING pragmas (Trac #9242)
[ghc.git] / testsuite / tests / simplCore / should_compile / simpl007.hs
1 {-# LANGUAGE UndecidableInstances,
2 ExistentialQuantification, FlexibleInstances #-}
3
4 -- module Formula where
5 module Main where
6
7 import Prelude hiding (logBase)
8
9 import Data.Maybe
10
11 -------------------------------------------------------------------------------
12
13 -- Formula
14 -- The data type for formulas (algegraic expressions).
15 --
16 -- It should be an extensible type, so that users of
17 -- the library can add new kinds of formulas.
18 -- For example, in this prototype I explore:
19 -- integer constants (FInt)
20 -- unknown variables (FVar)
21 -- sums (FSum)
22 -- products (FPro)
23 -- powers (FPow)
24 -- logarithms (FLog)
25 -- The user of the library may want to extend it with
26 -- trigonometric formulas or derivative formulas, for
27 -- example.
28 --
29 -- The idea is to let each kind of formula be a new data
30 -- type. Similar operations with them are implemented
31 -- using overloading. So there is a class (FORMULA) to collect
32 -- them and each kind of formula should be an instance of it.
33
34 class (Eq f, Show f) => FORMULA f where
35 ty :: f -> FType
36 intVal :: f -> Integer
37 varName :: f -> String
38 argList :: f -> [Formula]
39 same :: (FORMULA f1) => f -> f1 -> Bool
40 intVal = error ""
41 varName = error ""
42 argList = error ""
43 same _ _ = False
44
45 -- By now extensibility is accomplished by existentialy
46 -- quantified type variables.
47
48 data Formula = forall f . ( FORMULA f
49 , AddT f
50 ) =>
51 Formula f
52
53 instance Show Formula where
54 show (Formula f) = show f
55
56 instance Eq Formula where
57 (Formula x) == (Formula y) = same x y
58
59 instance FORMULA Formula where
60 ty (Formula f) = ty f
61 intVal (Formula f) = intVal f
62 varName (Formula f) = varName f
63 argList (Formula f) = argList f
64 same (Formula f) = same f
65
66 -------------------------------------------------------------------------------
67
68 -- How to uniquely identify the type of formula?
69 -- Each type of formula is associated to a key (FType)
70 -- that identifies it.
71 --
72 -- Here I use an enumated data type. When extending
73 -- the library, the user will have to modify this
74 -- data type adding a new constant constructor.
75
76 data FType = INT
77 | VAR
78 | SUM
79 | PRO
80 | POW
81 | LOG
82 deriving (Eq,Ord,Enum,Show)
83
84 -------------------------------------------------------------------------------
85
86 -- Integer formula
87
88 data FInt = FInt Integer
89 deriving (Eq,Show)
90
91 mkInt = Formula . FInt
92
93 instance FORMULA FInt where
94 ty _ = INT
95 intVal (FInt x) = x
96 same (FInt x) y = isInt y && x == intVal y
97
98 -- Variable formula
99
100 data FVar = FVar String
101 deriving (Eq,Show)
102
103 mkVar = Formula . FVar
104
105 instance FORMULA FVar where
106 ty _ = VAR
107 varName (FVar x) = x
108 same (FVar x) y = isVar y && x == varName y
109
110 -- Sum formula
111
112 data FSum = FSum [Formula]
113 deriving (Eq,Show)
114
115 mkSum = Formula . FSum
116
117 instance FORMULA FSum where
118 ty _ = SUM
119 argList (FSum xs) = xs
120 same (FSum xs) y = isSum y && xs == argList y
121
122 -- Product formula
123
124 data FPro = FPro [Formula]
125 deriving (Eq,Show)
126
127 mkPro = Formula . FPro
128
129 instance FORMULA FPro where
130 ty _ = PRO
131 argList (FPro xs) = xs
132 same (FPro xs) y = isPro y && xs == argList y
133
134 -- Exponentiation formula
135
136 data FPow = FPow Formula Formula
137 deriving (Eq,Show)
138
139 mkPow x y = Formula (FPow x y)
140
141 instance FORMULA FPow where
142 ty _ = POW
143 argList (FPow b e) = [b,e]
144 same (FPow b e) y = isPow y && [b,e] == argList y
145
146 -- Logarithm formula
147
148 data FLog = FLog Formula Formula
149 deriving (Eq,Show)
150
151 mkLog x b = Formula (FLog x b)
152
153 instance FORMULA FLog where
154 ty _ = LOG
155 argList (FLog x b) = [x,b]
156 same (FLog x b) y = isLog y && [x,b] == argList y
157
158 -------------------------------------------------------------------------------
159
160 -- Some predicates
161
162 isInt x = ty x == INT
163 isVar x = ty x == VAR
164 isSum x = ty x == SUM
165 isPro x = ty x == PRO
166 isPow x = ty x == POW
167
168 isZero x = isInt x && intVal x == 0
169
170 -------------------------------------------------------------------------------
171
172 -- Adding two formulas
173 -- This is a really very simple algorithm for adding
174 -- two formulas.
175
176 add :: Formula -> Formula -> Formula
177 add x y
178 | isJust u = fromJust u
179 | isJust v = fromJust v
180 | otherwise = mkSum [x,y]
181 where
182 u = addT x y
183 v = addT y x
184
185 class AddT a where
186 addT :: a -> Formula -> Maybe Formula
187 addT _ _ = Nothing
188
189 instance {-# OVERLAPPABLE #-} (FORMULA a) => AddT a where {}
190
191 instance AddT Formula where
192 addT (Formula f) = addT f
193
194 instance AddT FInt where
195 addT (FInt 0) y = Just y
196 addT (FInt x) y
197 | isInt y = Just (mkInt (x + intVal y))
198 | otherwise = Nothing
199
200 instance AddT FSum where
201 addT (FSum xs) y
202 | isSum y = Just (mkSum (merge xs (argList y)))
203 | otherwise = Just (mkSum (merge xs [y]))
204 where
205 merge = (++)
206
207 instance AddT FLog where
208 addT (FLog x b) y
209 | isLog y && b == logBase y = Just (mkLog (mkPro [x,logExp y]) b)
210 | otherwise = Nothing
211 where
212 merge = (++)
213
214 isLog x = ty x == LOG
215
216 logBase x
217 | isLog x = head (tail (argList x))
218
219 logExp x
220 | isLog x = head (argList x)
221
222 -------------------------------------------------------------------------------
223
224 -- Test addition of formulas
225
226 main = print [ add (mkInt 78) (mkInt 110)
227 , add (mkInt 0) (mkVar "x")
228 , add (mkVar "x") (mkInt 0)
229 , add (mkVar "x") (mkVar "y")
230 , add (mkSum [mkInt 13,mkVar "x"]) (mkVar "y")
231 , add (mkLog (mkVar "x") (mkInt 10))
232 (mkLog (mkVar "y") (mkInt 10))
233 , add (mkLog (mkVar "x") (mkInt 10))
234 (mkLog (mkVar "y") (mkVar "e"))
235 ]