Reorder and complete polymorphic properties
[darcs-mirrors/vector.git] / tests / Utilities.hs
1 module Utilities where
2
3 import Test.QuickCheck
4
5 import qualified Data.Vector as DV
6 import qualified Data.Vector.Generic as DVG
7 import qualified Data.Vector.Primitive as DVP
8 import qualified Data.Vector.Fusion.Stream as S
9
10 import Data.List ( sortBy )
11
12
13 instance Show a => Show (S.Stream a) where
14 show s = "Data.Vector.Fusion.Stream.fromList " ++ show (S.toList s)
15
16
17 instance Arbitrary a => Arbitrary (DV.Vector a) where
18 arbitrary = fmap DV.fromList arbitrary
19 coarbitrary = coarbitrary . DV.toList
20
21 instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where
22 arbitrary = fmap DVP.fromList arbitrary
23 coarbitrary = coarbitrary . DVP.toList
24
25 instance Arbitrary a => Arbitrary (S.Stream a) where
26 arbitrary = fmap S.fromList arbitrary
27 coarbitrary = coarbitrary . S.toList
28
29
30 class Model a b | a -> b where
31 -- | Convert a concrete value into an abstract model
32 model :: a -> b
33
34 -- The meat of the models
35 instance Model (DV.Vector a) [a] where model = DV.toList
36 instance DVP.Prim a => Model (DVP.Vector a) [a] where model = DVP.toList
37
38 -- Identity models
39 instance Model Bool Bool where model = id
40 instance Model Int Int where model = id
41 instance Model Float Float where model = id
42 instance Model Double Double where model = id
43 instance Model Ordering Ordering where model = id
44
45 -- Functorish models
46 -- All of these need UndecidableInstances although they are actually well founded. Oh well.
47 instance Model a b => Model (Maybe a) (Maybe b) where model = fmap model
48 instance Model a b => Model [a] [b] where model = fmap model
49 instance (Model a a', Model b b') => Model (a, b) (a', b') where model (a, b) = (model a, model b)
50 instance (Model a a', Model b b', Model c c') => Model (a, b, c) (a', b', c') where model (a, b, c) = (model a, model b, model c)
51 instance (Model c a, Model b d) => Model (a -> b) (c -> d) where model f = model . f . model
52
53
54 eq0 f g = model f == g
55 eq1 f g = \a -> model (f a) == g (model a)
56 eq2 f g = \a b -> model (f a b) == g (model a) (model b)
57 eq3 f g = \a b c -> model (f a b c) == g (model a) (model b) (model c)
58 eq4 f g = \a b c d -> model (f a b c d) == g (model a) (model b) (model c) (model d)
59
60 eqNotNull1 f g = \a -> (not (DVG.null a)) ==> eq1 f g a
61 eqNotNull2 f g = \a b -> (not (DVG.null b)) ==> eq2 f g a b
62 eqNotNull3 f g = \a b c -> (not (DVG.null c)) ==> eq3 f g a b c
63 eqNotNull4 f g = \a b c d -> (not (DVG.null d)) ==> eq4 f g a b c d
64
65 -- Generators
66 index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)]
67 index_value_pairs 0 = return []
68 index_value_pairs m = sized $ \n ->
69 do
70 len <- choose (0,n)
71 is <- sequence [choose (0,m-1) | i <- [1..len]]
72 xs <- vector len
73 return $ zip is xs
74
75 indices :: Int -> Gen [Int]
76 indices 0 = return []
77 indices m = sized $ \n ->
78 do
79 len <- choose (0,n)
80 sequence [choose (0,m-1) | i <- [1..len]]
81
82
83 -- Additional list functions
84 singleton x = [x]
85 snoc xs x = xs ++ [x]
86 slice xs i n = take n (drop i xs)
87 backpermute xs is = map (xs!!) is
88 prescanl f z = init . scanl f z
89 postscanl f z = tail . scanl f z
90
91 accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a]
92 accum f xs ps = go xs ps' 0
93 where
94 ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
95
96 go (x:xs) ((i,y) : ps) j
97 | i == j = go (f x y : xs) ps j
98 go (x:xs) ps j = x : go xs ps (j+1)
99 go [] _ _ = []
100
101 (//) :: [a] -> [(Int, a)] -> [a]
102 xs // ps = go xs ps' 0
103 where
104 ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
105
106 go (x:xs) ((i,y) : ps) j
107 | i == j = go (y:xs) ps j
108 go (x:xs) ps j = x : go xs ps (j+1)
109 go [] _ _ = []
110