Nicer properties and QuickCheck2
[darcs-mirrors/vector.git] / tests / Utilities.hs
1 {-# LANGUAGE FlexibleInstances, GADTs #-}
2 module Utilities where
3
4 import Test.QuickCheck
5
6 import qualified Data.Vector as DV
7 import qualified Data.Vector.Generic as DVG
8 import qualified Data.Vector.Primitive as DVP
9 import qualified Data.Vector.Fusion.Stream as S
10
11 import Data.List ( sortBy )
12
13
14 instance Show a => Show (S.Stream a) where
15 show s = "Data.Vector.Fusion.Stream.fromList " ++ show (S.toList s)
16
17
18 instance Arbitrary a => Arbitrary (DV.Vector a) where
19 arbitrary = fmap DV.fromList arbitrary
20
21 instance CoArbitrary a => CoArbitrary (DV.Vector a) where
22 coarbitrary = coarbitrary . DV.toList
23
24 instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where
25 arbitrary = fmap DVP.fromList arbitrary
26
27 instance (CoArbitrary a, DVP.Prim a) => CoArbitrary (DVP.Vector a) where
28 coarbitrary = coarbitrary . DVP.toList
29
30 instance Arbitrary a => Arbitrary (S.Stream a) where
31 arbitrary = fmap S.fromList arbitrary
32
33 instance CoArbitrary a => CoArbitrary (S.Stream a) where
34 coarbitrary = coarbitrary . S.toList
35
36
37 class Modelled a where
38 type Model a
39 -- | Convert a concrete value into an abstract model
40 model :: a -> Model a
41 unmodel :: Model a -> a
42
43 -- The meat of the models
44 instance Modelled (DV.Vector a) where
45 type Model (DV.Vector a) = [a]
46 model = DV.toList
47 unmodel = DV.fromList
48
49 instance DVP.Prim a => Modelled (DVP.Vector a) where
50 type Model (DVP.Vector a) = [a]
51 model = DVP.toList
52 unmodel = DVP.fromList
53
54 -- Identity models
55
56 #define id_Modelled(ty) \
57 instance Modelled ty where { type Model ty = ty; model = id; unmodel = id }
58
59 id_Modelled(Bool)
60 id_Modelled(Int)
61 id_Modelled(Float)
62 id_Modelled(Double)
63 id_Modelled(Ordering)
64
65 -- Functorish models
66 -- All of these need UndecidableInstances although they are actually well founded. Oh well.
67 instance Modelled a => Modelled (Maybe a) where
68 type Model (Maybe a) = Maybe (Model a)
69 model = fmap model
70 unmodel = fmap unmodel
71
72 instance Modelled a => Modelled [a] where
73 type Model [a] = [Model a]
74 model = fmap model
75 unmodel = fmap unmodel
76
77 instance (Modelled a, Modelled b) => Modelled (a,b) where
78 type Model (a,b) = (Model a, Model b)
79 model (a,b) = (model a, model b)
80 unmodel (a,b) = (unmodel a, unmodel b)
81
82 instance (Modelled a, Modelled b, Modelled c) => Modelled (a,b,c) where
83 type Model (a,b,c) = (Model a, Model b, Model c)
84 model (a,b,c) = (model a, model b, model c)
85 unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c)
86
87 instance (Modelled a, Modelled b) => Modelled (a -> b) where
88 type Model (a -> b) = Model a -> Model b
89 model f = model . f . unmodel
90 unmodel f = unmodel . f . model
91
92 class (Testable (Pty a), Predicate (Pty a)) => PropLike a where
93 type Pty a
94
95 instance (Arbitrary a, Show a, PropLike b) => PropLike (a -> b) where
96 type Pty (a -> b) = a -> Pty b
97
98 #define PropLike0(ty) \
99 instance PropLike (ty) where { type Pty (ty) = Property }
100
101 PropLike0(Int)
102 PropLike0(Bool)
103 PropLike0(Float)
104 PropLike0(Double)
105 PropLike0(Ordering)
106 PropLike0([a])
107 PropLike0(Maybe a)
108 PropLike0((a,b))
109 PropLike0((a,b,c))
110 PropLike0(DV.Vector a)
111 PropLike0(DVP.Vector a)
112 PropLike0(S.Stream a)
113
114 data P a where
115 P :: PropLike a => Pty a -> P a
116
117 unP :: P a -> Pty a
118 unP (P p) = p
119
120
121 instance Testable (P a) where
122 property (P a) = property a
123
124 class PropLike a => EqTestable a p where
125 equal :: a -> a -> p
126
127 instance (Eq a, PropLike a) => EqTestable a Property where
128 equal x y = property (x==y)
129
130 instance (Arbitrary a, Show a, EqTestable b p) => EqTestable (a -> b) (a -> p) where
131 equal f g = \x -> equal (f x) (g x)
132
133 infix 4 `eq`
134 eq :: (Modelled a, EqTestable a (Pty a)) => a -> Model a -> P a
135 eq x y = P (equal x (unmodel y))
136
137 class Predicate p where
138 type Pred p
139
140 predicate :: Pred p -> p -> p
141
142 instance Predicate Property where
143 type Pred Property = Bool
144
145 predicate = (==>)
146
147 instance Predicate p => Predicate (a -> p) where
148 type Pred (a -> p) = a -> Pred p
149
150 predicate f p = \x -> predicate (f x) (p x)
151
152 infixr 0 ===>
153 (===>) :: Pred (Pty a) -> P a -> P a
154 p ===> P a = P (predicate p a)
155
156 notNull2 _ xs = not $ DVG.null xs
157
158 {-
159 class EqTestable a where
160 equal :: a -> a -> P a
161
162 #define EqTestable0(ty) \
163 instance EqTestable (ty) where { equal x y = P (property (x == y)) }
164
165 EqTestable0(Bool)
166 EqTestable0(Int)
167 EqTestable0(Float)
168 EqTestable0(Double)
169 EqTestable0(Ordering)
170
171 #define EqTestable1(ty) \
172 instance Eq a => EqTestable (ty a) where { equal x y = P (property (x == y)) }
173
174 EqTestable1(Maybe)
175 EqTestable1([])
176 EqTestable1(DV.Vector)
177 EqTestable1(S.Stream)
178
179 instance (Eq a, DVP.Prim a) => EqTestable (DVP.Vector a) where
180 equal x y = P (property (x == y))
181
182 instance (Eq a, Eq b) => EqTestable (a,b) where
183 equal x y = P (property (x == y))
184
185 instance (Eq a, Eq b, Eq c) => EqTestable (a,b,c) where
186 equal x y = P (property (x == y))
187
188 instance (Arbitrary a, Show a, EqTestable b) => EqTestable (a -> b) where
189 equal f g = P (\x -> unP (f x `equal` g x))
190
191 infix 4 `eq`
192 eq :: (Modelled a, EqTestable a) => a -> Model a -> P a
193 x `eq` y = x `equal` unmodel y
194 -}
195
196 {-
197 class (Predicate (EqTest a), Testable (EqTest a)) => EqTestable a where
198 type EqTest a
199
200 equal :: a -> a -> EqTest a
201
202 #define EqTestable0(ty) \
203 instance EqTestable (ty) where { type EqTest (ty) = Bool; equal = (==) }
204
205 EqTestable0(Bool)
206 EqTestable0(Int)
207 EqTestable0(Float)
208 EqTestable0(Double)
209 EqTestable0(Ordering)
210
211 #define EqTestable1(ty) \
212 instance Eq a => EqTestable (ty a) where { type EqTest (ty a) = Bool; equal = (==) }
213
214 EqTestable1(Maybe)
215 EqTestable1([])
216 EqTestable1(DV.Vector)
217 EqTestable1(S.Stream)
218
219 instance (Eq a, DVP.Prim a) => EqTestable (DVP.Vector a) where
220 type EqTest (DVP.Vector a) = Bool
221 equal = (==)
222
223 instance (Eq a, Eq b) => EqTestable (a,b) where
224 type EqTest (a,b) = Bool
225 equal = (==)
226
227 instance (Eq a, Eq b, Eq c) => EqTestable (a,b,c) where
228 type EqTest (a,b,c) = Bool
229 equal = (==)
230
231 instance (Arbitrary a, Show a, EqTestable b) => EqTestable (a -> b) where
232 type EqTest (a -> b) = a -> EqTest b
233
234 equal f g x = f x `equal` g x
235
236 newtype P a = P (EqTest a)
237
238 instance EqTestable a => Testable (P a) where
239 property (P t) = property t
240
241
242 infix 4 `eq`
243 eq :: (Modelled a, EqTestable a) => a -> Model a -> P a
244 x `eq` y = P (x `equal` unmodel y)
245
246 class Testable (Pty f) => Predicate f where
247 type Pred f
248 type Pty f
249
250 infixr 0 ===>
251 (===>) :: Pred f -> f -> Pty f
252
253 instance Predicate Bool where
254 type Pred Bool = Bool
255 type Pty Bool = Property
256
257 (===>) = (==>)
258
259 instance (Arbitrary a, Show a, Predicate f) => Predicate (a -> f) where
260 type Pred (a -> f) = a -> Pred f
261 type Pty (a -> f) = a -> Pty f
262
263 p ===> f = \x -> p x ===> f x
264
265 notNull2 _ xs = not $ DVG.null xs
266 -}
267
268 -- Generators
269 index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)]
270 index_value_pairs 0 = return []
271 index_value_pairs m = sized $ \n ->
272 do
273 len <- choose (0,n)
274 is <- sequence [choose (0,m-1) | i <- [1..len]]
275 xs <- vector len
276 return $ zip is xs
277
278 indices :: Int -> Gen [Int]
279 indices 0 = return []
280 indices m = sized $ \n ->
281 do
282 len <- choose (0,n)
283 sequence [choose (0,m-1) | i <- [1..len]]
284
285
286 -- Additional list functions
287 singleton x = [x]
288 snoc xs x = xs ++ [x]
289 slice xs i n = take n (drop i xs)
290 backpermute xs is = map (xs!!) is
291 prescanl f z = init . scanl f z
292 postscanl f z = tail . scanl f z
293
294 accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a]
295 accum f xs ps = go xs ps' 0
296 where
297 ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
298
299 go (x:xs) ((i,y) : ps) j
300 | i == j = go (f x y : xs) ps j
301 go (x:xs) ps j = x : go xs ps (j+1)
302 go [] _ _ = []
303
304 (//) :: [a] -> [(Int, a)] -> [a]
305 xs // ps = go xs ps' 0
306 where
307 ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
308
309 go (x:xs) ((i,y) : ps) j
310 | i == j = go (y:xs) ps j
311 go (x:xs) ps j = x : go xs ps (j+1)
312 go [] _ _ = []
313