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