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