Move tests from tests/ghc-regress/* to just tests/*
[ghc.git] / testsuite / tests / programs / maessen-hashtab / HashTest.hs
1 {- Test code for Data.HashTable -}
2
3 module Main(main) where
4
5 import Prelude hiding (lookup)
6 import qualified Prelude (lookup)
7 import Data.Maybe(isJust,isNothing)
8 import Data.Int(Int32)
9 import Test.QuickCheck
10 import System.IO.Unsafe(unsafePerformIO)
11 import Data.HashTab
12 import Control.Monad(liftM2, foldM)
13 import System.Random
14 import System.Environment
15
16 infixr 0 ==.
17 infixr 0 ==~
18 infixr 0 ~~
19
20 type HT = HashTable Int Int
21 newtype HashFun = HF {unHF :: (Int -> Int32)}
22 data Empty = E {e :: (IO HT), hfe :: HashFun}
23 data MkH = H {h :: (IO HT), hfh :: HashFun}
24 newtype List a = L [a]
25
26 data Action = Lookup Int
27 | Insert Int Int
28 | Delete Int
29 | Update Int Int
30 deriving (Show)
31
32 instance Arbitrary Action where
33 arbitrary = frequency [(10,fmap Lookup arbitrary),
34 (5, liftM2 Insert arbitrary arbitrary),
35 (3, liftM2 Update arbitrary arbitrary),
36 (1, fmap Delete arbitrary)]
37 coarbitrary = error "coarbitrary Action"
38
39 simA :: [Action] -> [Either Bool [Int]]
40 simA = fst . foldl sim ([],[])
41 where sim :: ([Either Bool [Int]], [Action]) -> Action ->
42 ([Either Bool [Int]], [Action])
43 sim (res, past) (Lookup k) = (Right (lkup k past) : res, past)
44 sim (res, past) (Insert k v) = (res, Insert k v : past)
45 sim (res, past) (Delete k) = (res, Delete k : past)
46 sim (res, past) (Update k v) =
47 (Left (not (null l)) : res, Update k v : past)
48 where l = lkup k past
49 lkup _ [] = []
50 lkup k (Delete k' : _)
51 | k==k' = []
52 lkup k (Update k' v : _)
53 | k==k' = [v]
54 lkup k (Insert k' v : past)
55 | k==k' = v:lkup k past
56 lkup k (_ : past) = lkup k past
57
58 runA :: HashFun -> [Action] -> IO [Either Bool (Maybe Int)]
59 runA hf acts = do
60 ht <- new (==) (unHF hf)
61 let run res (Lookup a) = fmap (lkup res) $ lookup ht a
62 run res (Insert k v) = insert ht k v >> return res
63 run res (Delete k) = delete ht k >> return res
64 run res (Update k v) = fmap (upd res) $ update ht k v
65 lkup res m = Right m : res
66 upd res b = Left b : res
67 foldM run [] acts
68
69 (~~) :: IO [Either Bool (Maybe Int)] -> [Either Bool [Int]] -> Bool
70 acts ~~ sims = and $ zipWith same (unsafePerformIO acts) sims
71 where same (Left b) (Left b') = b==b'
72 same (Right Nothing) (Right []) = True
73 same (Right (Just a)) (Right xs) = a `elem` xs
74 same _ _ = False
75
76 lookups :: HT -> [Int] -> IO [Maybe Int]
77 lookups ht ks = mapM (lookup ht) ks
78
79 instance Show HashFun where
80 showsPrec _ (HF hf) r
81 | hf 1 == 0 = "degenerate"++r
82 | otherwise = "usual"++r
83
84 instance Show Empty where
85 showsPrec _ ee r = shows (hfe ee) r
86
87 instance Show MkH where
88 showsPrec _ hh r = shows (hfh hh) $
89 ("; "++shows (unsafePerformIO (h hh >>= toList)) r)
90
91 instance Show a => Show (List a) where
92 showsPrec _ (L l) r = shows l r
93
94 instance Arbitrary HashFun where
95 arbitrary = frequency [(20,return (HF hashInt)),
96 (1,return (HF (const 0)))]
97 coarbitrary = error "coarbitrary HashFun"
98
99 instance Arbitrary Empty where
100 arbitrary = fmap mkE arbitrary
101 where mkE (HF hf) = E {e = new (==) hf, hfe=HF hf}
102 coarbitrary = error "coarbitrary Empty"
103
104 instance Arbitrary a => Arbitrary (List a) where
105 arbitrary = do
106 sz <- frequency [(50, sized return),
107 (1,return (4096*2)),
108 (0, return (1024*1024))]
109 resize sz $ fmap L $ sized vector
110 coarbitrary = error "coarbitrary (List a)"
111
112 instance Arbitrary MkH where
113 arbitrary = do
114 hf <- arbitrary
115 L list <- arbitrary
116 let mkH act = H { h = act, hfh = hf }
117 return (mkH . fromList (unHF hf) $ list)
118 coarbitrary = error "coarbitrary MkH"
119
120 (==~) :: (Eq a) => IO a -> IO a -> Bool
121 act1 ==~ act2 = unsafePerformIO act1 == unsafePerformIO act2
122
123 (==.) :: (Eq a) => IO a -> a -> Bool
124 act ==. v = unsafePerformIO act == v
125
126 notin :: (Testable a) => Int -> MkH -> a -> Property
127 k `notin` hh = \prop ->
128 let f = (not . isJust . unsafePerformIO) (h hh >>= flip lookup k) in
129 f `trivial` prop
130
131 prop_emptyLookup :: Empty -> Int -> Bool
132 prop_emptyLookup ee k =
133 isNothing . unsafePerformIO $
134 (do mt <- e ee
135 lookup mt k)
136
137 prop_emptyToList :: Empty -> Bool
138 prop_emptyToList ee =
139 (do mt <- e ee
140 toList mt) ==. []
141
142 prop_emptyFromList :: HashFun -> Int -> Bool
143 prop_emptyFromList hf k =
144 (do mt <- new (==) (unHF hf) :: IO HT
145 lookup mt k) ==~
146 (do mt <- fromList (unHF hf) []
147 lookup mt k)
148
149 prop_insert :: MkH -> Int -> Int -> Bool
150 prop_insert hh k v =
151 (do ht <- h hh
152 insert ht k v
153 lookup ht k) ==. Just v
154
155 prop_insertu :: MkH -> Int -> Int -> List Int -> Bool
156 prop_insertu hh k v (L ks) =
157 let ks' = filter (k /=) ks in
158 (do ht <- h hh
159 insert ht k v
160 lookups ht ks') ==~
161 (do ht <- h hh
162 lookups ht ks')
163
164 prop_delete :: MkH -> Int -> Property
165 prop_delete hh k =
166 k `notin` hh $
167 isNothing . unsafePerformIO $
168 (do ht <- h hh
169 delete ht k
170 lookup ht k)
171
172 prop_deleteu :: MkH -> Int -> List Int -> Bool
173 prop_deleteu hh k (L ks) =
174 let ks' = filter (k /=) ks in
175 (do ht <- h hh
176 delete ht k
177 lookups ht ks') ==~
178 (do ht <- h hh
179 lookups ht ks')
180
181 naiveUpdate :: HT -> Int -> Int -> IO ()
182 naiveUpdate ht k v = do
183 delete ht k
184 insert ht k v
185
186 prop_update :: MkH -> Int -> Int -> List Int -> Bool
187 prop_update hh k v (L ks) =
188 (do ht <- h hh
189 _ <- update ht k v
190 lookups ht ks) ==~
191 (do ht <- h hh
192 naiveUpdate ht k v
193 lookups ht ks)
194
195 prop_updatec :: MkH -> Int -> Int -> Bool
196 prop_updatec hh k v =
197 (do ht <- h hh
198 _ <- update ht k v
199 lookup ht k) ==. Just v
200
201 prop_updateLookup :: MkH -> Int -> Int -> Property
202 prop_updateLookup hh k v =
203 k `notin` hh $
204 (do ht <- h hh
205 update ht k v) ==~
206 (do ht <- h hh
207 fmap isJust (lookup ht k))
208
209 prop_simulation :: HashFun -> List Action -> Property
210 prop_simulation hf (L acts) =
211 (null acts `trivial`) $
212 runA hf acts ~~ simA acts
213
214 {-
215
216 For "fromList" and "toList" properties we're a bit sloppy: we perform
217 multiple insertions for a key (potentially) but give nor promises
218 about which one we will retrieve with lookup, or what order they'll be
219 returned by toList (or if they'll all be returned at all). Thus we
220 insert all occurrences of a key with the same value, and do all
221 checking via lookups.
222
223 -}
224
225 prop_fromList :: HashFun -> List Int -> List Int -> Property
226 prop_fromList hf (L l) (L ks) =
227 null l `trivial`
228 let assocs = map (\t -> (t,t)) l in
229 ( do ht <- fromList (unHF hf) assocs
230 lookups ht ks) ==. (map (`Prelude.lookup` assocs) ks)
231
232 prop_fromListInsert :: HashFun -> List (Int,Int) -> Int -> Int -> List Int -> Property
233 prop_fromListInsert hf (L l) k v (L ks) =
234 null l `trivial`
235 (( do ht <- fromList (unHF hf) l
236 insert ht k v
237 lookups ht ks) ==~
238 ( do ht <- fromList (unHF hf) (l++[(k,v)])
239 lookups ht ks))
240
241 prop_toList :: HashFun -> List Int -> List Int -> Property
242 prop_toList hf (L l) (L ks) =
243 null l `trivial`
244 let assocs = map (\t -> (t,t)) l in
245 ( do ht <- fromList (unHF hf) assocs
246 lookups ht ks) ==~
247 ( do ht <- fromList (unHF hf) assocs
248 fmap (\as -> map (`Prelude.lookup` as) ks) $ toList ht )
249
250 te :: (Testable a) => String -> a -> IO ()
251 -- te name prop = putStrLn name >> verboseCheck prop
252 te name prop = do
253 putStr name
254 check (defaultConfig{configMaxTest = 500,
255 configMaxFail = 10000,
256 configEvery = \_ _ -> "" }) prop
257
258 main :: IO ()
259 main = do
260 [r] <- getArgs
261 setStdGen (mkStdGen (read r :: Int))
262 sequence_ $
263 [ te "emptyLookup:" prop_emptyLookup,
264 te "emptyToList:" prop_emptyToList,
265 te "emptyFromList:" prop_emptyFromList,
266 te "insert:" prop_insert,
267 te "insertu:" prop_insertu,
268 te "delete:" prop_delete,
269 te "deleteu:" prop_deleteu,
270 te "update:" prop_update,
271 te "updatec:" prop_updatec,
272 te "updateLookup:" prop_updateLookup,
273 te "fromList:" prop_fromList,
274 te "fromListInsert:" prop_fromListInsert,
275 te "toList:" prop_toList,
276 te "simulation:" prop_simulation
277 ]
278 putStrLn "OK"