Resolve conflict
[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.Storable as DVS
10 import qualified Data.Vector.Unboxed as DVU
11 import qualified Data.Vector.Fusion.Bundle as S
12
13 import Data.List ( sortBy )
14
15
16 instance Show a => Show (S.Bundle v a) where
17 show s = "Data.Vector.Fusion.Bundle.fromList " ++ show (S.toList s)
18
19
20 instance Arbitrary a => Arbitrary (DV.Vector a) where
21 arbitrary = fmap DV.fromList arbitrary
22
23 instance CoArbitrary a => CoArbitrary (DV.Vector a) where
24 coarbitrary = coarbitrary . DV.toList
25
26 instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where
27 arbitrary = fmap DVP.fromList arbitrary
28
29 instance (CoArbitrary a, DVP.Prim a) => CoArbitrary (DVP.Vector a) where
30 coarbitrary = coarbitrary . DVP.toList
31
32 instance (Arbitrary a, DVS.Storable a) => Arbitrary (DVS.Vector a) where
33 arbitrary = fmap DVS.fromList arbitrary
34
35 instance (CoArbitrary a, DVS.Storable a) => CoArbitrary (DVS.Vector a) where
36 coarbitrary = coarbitrary . DVS.toList
37
38 instance (Arbitrary a, DVU.Unbox a) => Arbitrary (DVU.Vector a) where
39 arbitrary = fmap DVU.fromList arbitrary
40
41 instance (CoArbitrary a, DVU.Unbox a) => CoArbitrary (DVU.Vector a) where
42 coarbitrary = coarbitrary . DVU.toList
43
44 instance Arbitrary a => Arbitrary (S.Bundle v a) where
45 arbitrary = fmap S.fromList arbitrary
46
47 instance CoArbitrary a => CoArbitrary (S.Bundle v a) where
48 coarbitrary = coarbitrary . S.toList
49
50 class (Testable (EqTest a), Conclusion (EqTest a)) => TestData a where
51 type Model a
52 model :: a -> Model a
53 unmodel :: Model a -> a
54
55 type EqTest a
56 equal :: a -> a -> EqTest a
57
58 instance Eq a => TestData (S.Bundle v a) where
59 type Model (S.Bundle v a) = [a]
60 model = S.toList
61 unmodel = S.fromList
62
63 type EqTest (S.Bundle v a) = Property
64 equal x y = property (x == y)
65
66 instance Eq a => TestData (DV.Vector a) where
67 type Model (DV.Vector a) = [a]
68 model = DV.toList
69 unmodel = DV.fromList
70
71 type EqTest (DV.Vector a) = Property
72 equal x y = property (x == y)
73
74 instance (Eq a, DVP.Prim a) => TestData (DVP.Vector a) where
75 type Model (DVP.Vector a) = [a]
76 model = DVP.toList
77 unmodel = DVP.fromList
78
79 type EqTest (DVP.Vector a) = Property
80 equal x y = property (x == y)
81
82 instance (Eq a, DVS.Storable a) => TestData (DVS.Vector a) where
83 type Model (DVS.Vector a) = [a]
84 model = DVS.toList
85 unmodel = DVS.fromList
86
87 type EqTest (DVS.Vector a) = Property
88 equal x y = property (x == y)
89
90 instance (Eq a, DVU.Unbox a) => TestData (DVU.Vector a) where
91 type Model (DVU.Vector a) = [a]
92 model = DVU.toList
93 unmodel = DVU.fromList
94
95 type EqTest (DVU.Vector a) = Property
96 equal x y = property (x == y)
97
98 #define id_TestData(ty) \
99 instance TestData ty where { \
100 type Model ty = ty; \
101 model = id; \
102 unmodel = id; \
103 \
104 type EqTest ty = Property; \
105 equal x y = property (x == y) }
106
107 id_TestData(())
108 id_TestData(Bool)
109 id_TestData(Int)
110 id_TestData(Float)
111 id_TestData(Double)
112 id_TestData(Ordering)
113
114 -- Functorish models
115 -- All of these need UndecidableInstances although they are actually well founded. Oh well.
116 instance (Eq a, TestData a) => TestData (Maybe a) where
117 type Model (Maybe a) = Maybe (Model a)
118 model = fmap model
119 unmodel = fmap unmodel
120
121 type EqTest (Maybe a) = Property
122 equal x y = property (x == y)
123
124 instance (Eq a, TestData a) => TestData [a] where
125 type Model [a] = [Model a]
126 model = fmap model
127 unmodel = fmap unmodel
128
129 type EqTest [a] = Property
130 equal x y = property (x == y)
131
132 instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where
133 type Model (a,b) = (Model a, Model b)
134 model (a,b) = (model a, model b)
135 unmodel (a,b) = (unmodel a, unmodel b)
136
137 type EqTest (a,b) = Property
138 equal x y = property (x == y)
139
140 instance (Eq a, Eq b, Eq c, TestData a, TestData b, TestData c) => TestData (a,b,c) where
141 type Model (a,b,c) = (Model a, Model b, Model c)
142 model (a,b,c) = (model a, model b, model c)
143 unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c)
144
145 type EqTest (a,b,c) = Property
146 equal x y = property (x == y)
147
148 instance (Arbitrary a, Show a, TestData a, TestData b) => TestData (a -> b) where
149 type Model (a -> b) = Model a -> Model b
150 model f = model . f . unmodel
151 unmodel f = unmodel . f . model
152
153 type EqTest (a -> b) = a -> EqTest b
154 equal f g x = equal (f x) (g x)
155
156 newtype P a = P { unP :: EqTest a }
157
158 instance TestData a => Testable (P a) where
159 property (P a) = property a
160
161 infix 4 `eq`
162 eq :: TestData a => a -> Model a -> P a
163 eq x y = P (equal x (unmodel y))
164
165 class Conclusion p where
166 type Predicate p
167
168 predicate :: Predicate p -> p -> p
169
170 instance Conclusion Property where
171 type Predicate Property = Bool
172
173 predicate = (==>)
174
175 instance Conclusion p => Conclusion (a -> p) where
176 type Predicate (a -> p) = a -> Predicate p
177
178 predicate f p = \x -> predicate (f x) (p x)
179
180 infixr 0 ===>
181 (===>) :: TestData a => Predicate (EqTest a) -> P a -> P a
182 p ===> P a = P (predicate p a)
183
184 notNull2 _ xs = not $ DVG.null xs
185 notNullS2 _ s = not $ S.null s
186
187 -- Generators
188 index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)]
189 index_value_pairs 0 = return []
190 index_value_pairs m = sized $ \n ->
191 do
192 len <- choose (0,n)
193 is <- sequence [choose (0,m-1) | i <- [1..len]]
194 xs <- vector len
195 return $ zip is xs
196
197 indices :: Int -> Gen [Int]
198 indices 0 = return []
199 indices m = sized $ \n ->
200 do
201 len <- choose (0,n)
202 sequence [choose (0,m-1) | i <- [1..len]]
203
204
205 -- Additional list functions
206 singleton x = [x]
207 snoc xs x = xs ++ [x]
208 generate n f = [f i | i <- [0 .. n-1]]
209 slice i n xs = take n (drop i xs)
210 backpermute xs is = map (xs!!) is
211 prescanl f z = init . scanl f z
212 postscanl f z = tail . scanl f z
213 prescanr f z = tail . scanr f z
214 postscanr f z = init . scanr f z
215
216 accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a]
217 accum f xs ps = go xs ps' 0
218 where
219 ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
220
221 go (x:xs) ((i,y) : ps) j
222 | i == j = go (f x y : xs) ps j
223 go (x:xs) ps j = x : go xs ps (j+1)
224 go [] _ _ = []
225
226 (//) :: [a] -> [(Int, a)] -> [a]
227 xs // ps = go xs ps' 0
228 where
229 ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
230
231 go (x:xs) ((i,y) : ps) j
232 | i == j = go (y:xs) ps j
233 go (x:xs) ps j = x : go xs ps (j+1)
234 go [] _ _ = []
235
236 imap :: (Int -> a -> a) -> [a] -> [a]
237 imap f = map (uncurry f) . zip [0..]
238
239 izipWith :: (Int -> a -> a -> a) -> [a] -> [a] -> [a]
240 izipWith f = zipWith (uncurry f) . zip [0..]
241
242 izipWith3 :: (Int -> a -> a -> a -> a) -> [a] -> [a] -> [a] -> [a]
243 izipWith3 f = zipWith3 (uncurry f) . zip [0..]
244
245 ifilter :: (Int -> a -> Bool) -> [a] -> [a]
246 ifilter f = map snd . filter (uncurry f) . zip [0..]
247
248 ifoldl :: (a -> Int -> a -> a) -> a -> [a] -> a
249 ifoldl f z = foldl (uncurry . f) z . zip [0..]
250
251 ifoldr :: (Int -> a -> b -> b) -> b -> [a] -> b
252 ifoldr f z = foldr (uncurry f) z . zip [0..]
253
254 minIndex :: Ord a => [a] -> Int
255 minIndex = fst . foldr1 imin . zip [0..]
256 where
257 imin (i,x) (j,y) | x <= y = (i,x)
258 | otherwise = (j,y)
259
260 maxIndex :: Ord a => [a] -> Int
261 maxIndex = fst . foldr1 imax . zip [0..]
262 where
263 imax (i,x) (j,y) | x >= y = (i,x)
264 | otherwise = (j,y)
265