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