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