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