hashtables-1.0.0.0: test/suite/Data/HashTable/Test/Common.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
module Data.HashTable.Test.Common
( FixedTableType
, dummyTable
, forceType
, tests
) where
------------------------------------------------------------------------------
import Control.Monad (liftM, when)
import Control.Monad.ST (unsafeIOToST)
import Data.IORef
import Data.List hiding ( insert
, delete
, lookup )
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import Prelude hiding (lookup, mapM_)
import System.Random.MWC
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
import Test.QuickCheck.Monadic
------------------------------------------------------------------------------
import qualified Data.HashTable.Class as C
import Data.HashTable.IO
------------------------------------------------------------------------------
type FixedTableType h = forall k v . IOHashTable h k v
type HashTest = forall h . C.HashTable h => String -> FixedTableType h -> Test
data SomeTest = SomeTest HashTest
------------------------------------------------------------------------------
assertEq :: (Eq a, Show a) =>
String -> a -> a -> PropertyM IO ()
assertEq s expected got =
when (expected /= got) $ do
fail $ s ++ ": expected '" ++ show expected ++ "', got '"
++ show got ++ "'"
------------------------------------------------------------------------------
forceType :: forall m h k1 k2 v1 v2 . (Monad m, C.HashTable h) =>
IOHashTable h k1 v1 -> IOHashTable h k2 v2 -> m ()
forceType _ _ = return ()
------------------------------------------------------------------------------
dummyTable :: forall k v h . C.HashTable h => IOHashTable h k v
dummyTable = undefined
------------------------------------------------------------------------------
tests :: C.HashTable h => String -> FixedTableType h -> Test
tests prefix dummyArg = testGroup prefix $ map f ts
where
f (SomeTest ht) = ht prefix dummyArg
ts = [ SomeTest testFromListToList
, SomeTest testInsert
, SomeTest testInsert2
, SomeTest testNewAndInsert
, SomeTest testGrowTable
, SomeTest testDelete
]
------------------------------------------------------------------------------
testFromListToList :: HashTest
testFromListToList prefix dummyArg =
testProperty (prefix ++ "/fromListToList") $
monadicIO $ do
rng <- initializeRNG
forAllM arbitrary $ prop rng
where
prop :: GenIO -> [(Int, Int)] -> PropertyM IO ()
prop rng origL = do
let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL
ht <- run $ fromList l
l' <- run $ toList ht
assertEq "fromList . toList == id" (sort l) (sort l')
forceType dummyArg ht
------------------------------------------------------------------------------
testInsert :: HashTest
testInsert prefix dummyArg =
testProperty (prefix ++ "/insert") $
monadicIO $ do
rng <- initializeRNG
forAllM arbitrary $ prop rng
where
prop :: GenIO -> ([(Int, Int)], (Int,Int)) -> PropertyM IO ()
prop rng (origL, (k,v)) = do
let l = V.toList $ shuffle rng $ V.fromList $ remove k $ dedupe origL
assert $ all (\t -> fst t /= k) l
ht <- run $ fromList l
nothing <- run $ lookup ht k
assertEq ("lookup " ++ show k) Nothing nothing
run $ insert ht k v
r <- run $ lookup ht k
assertEq ("lookup2 " ++ show k) (Just v) r
forceType dummyArg ht
------------------------------------------------------------------------------
testInsert2 :: HashTest
testInsert2 prefix dummyArg =
testProperty (prefix ++ "/insert2") $
monadicIO $ do
rng <- initializeRNG
forAllM arbitrary $ prop rng
where
prop :: GenIO -> ([(Int, Int)], (Int,Int,Int)) -> PropertyM IO ()
prop rng (origL, (k,v,v2)) = do
let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL
ht <- run $ fromList l
run $ insert ht k v
r <- run $ lookup ht k
assertEq ("lookup1 " ++ show k) (Just v) r
run $ insert ht k v2
r' <- run $ lookup ht k
assertEq ("lookup2 " ++ show k) (Just v2) r'
forceType dummyArg ht
------------------------------------------------------------------------------
testNewAndInsert :: HashTest
testNewAndInsert prefix dummyArg =
testProperty (prefix ++ "/newAndInsert") $
monadicIO $ forAllM arbitrary prop
where
prop :: (Int,Int,Int) -> PropertyM IO ()
prop (k,v,v2) = do
ht <- run new
nothing <- run $ lookup ht k
assertEq ("lookup " ++ show k) Nothing nothing
run $ insert ht k v
r <- run $ lookup ht k
assertEq ("lookup2 " ++ show k) (Just v) r
run $ insert ht k v2
r' <- run $ lookup ht k
assertEq ("lookup3 " ++ show k) (Just v2) r'
ctRef <- run $ newIORef (0::Int)
run $ mapM_ (const $ modifyIORef ctRef (+1)) ht
ct <- run $ readIORef ctRef
assertEq "count = 1" 1 ct
ct' <- run $ foldM (\i _ -> return $! i+1) (0::Int) ht
assertEq "count2 = 1" 1 ct'
forceType dummyArg ht
------------------------------------------------------------------------------
testGrowTable :: HashTest
testGrowTable prefix dummyArg =
testProperty (prefix ++ "/growTable") $
monadicIO $ forAllM generator prop
where
generator = choose (32,2048)
go n = new >>= go' (0::Int)
where
go' !i !ht | i >= n = return ht
| otherwise = do
insert ht i i
go' (i+1) ht
f (!m,!s) (!k,!v) = return $! (max m k, v `seq` s+1)
prop :: Int -> PropertyM IO ()
prop n = do
ht <- run $ go n
i <- liftM head $ run $ sample' $ choose (0,n-1)
v <- run $ lookup ht i
assertEq ("lookup " ++ show i) (Just i) v
ct <- run $ foldM f (0::Int, 0::Int) ht
assertEq "max + count" (n-1,n) ct
forceType dummyArg ht
------------------------------------------------------------------------------
testDelete :: HashTest
testDelete prefix dummyArg =
testProperty (prefix ++ "/delete") $
monadicIO $ forAllM generator prop
where
generator = choose (32,2048)
go n = new >>= go' (0::Int)
where
go' !i !ht | i >= n = return ht
| otherwise = do
insert ht i i
case i of
3 -> do
delete ht 2
delete ht 3
insert ht 2 2
_ -> if i `mod` 2 == 0
then do
delete ht i
insert ht i i
else return ()
go' (i+1) ht
f (!m,!s) (!k,!v) = return $! (max m k, v `seq` s+1)
prop :: Int -> PropertyM IO ()
prop n = do
ht <- run $ go n
i <- liftM head $ run $ sample' $ choose (4,n-1)
v <- run $ lookup ht i
assertEq ("lookup " ++ show i) (Just i) v
v3 <- run $ lookup ht 3
assertEq ("lookup 3") Nothing v3
ct <- run $ foldM f (0::Int, 0::Int) ht
assertEq "max + count" (n-1,n-1) ct
forceType dummyArg ht
------------------------------------------------------------------------------
initializeRNG :: PropertyM IO GenIO
initializeRNG = run $ withSystemRandom (return :: GenIO -> IO GenIO)
------------------------------------------------------------------------------
dedupe :: (Ord k, Ord v, Eq k) => [(k,v)] -> [(k,v)]
dedupe l = go0 $ sort l
where
go0 [] = []
go0 (x:xs) = go id x xs
go !dl !lastOne [] = (dl . (lastOne:)) []
go !dl !lastOne@(!lx,_) ((x,v):xs) =
if lx == x
then go dl lastOne xs
else go (dl . (lastOne:)) (x,v) xs
------------------------------------------------------------------------------
-- assumption: list is sorted.
remove :: (Ord k, Eq k) => k -> [(k,v)] -> [(k,v)]
remove m l = go id l
where
go !dl [] = dl []
go !dl ll@((k,v):xs) =
case compare k m of
LT -> go (dl . ((k,v):)) xs
EQ -> go dl xs
GT -> dl ll
------------------------------------------------------------------------------
shuffle :: GenIO -> Vector k -> Vector k
shuffle rng v = if V.null v then v else V.modify go v
where
!n = V.length v
go mv = f (n-1)
where
-- note: inclusive
pickOne b = unsafeIOToST $ uniformR (0,b) rng
swap = MV.unsafeSwap mv
f 0 = return ()
f !k = do
idx <- pickOne k
swap k idx
f (k-1)