Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

114 lines (86 sloc) 4.129 kb
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where
import Data.Hashable (Hashable(hashWithSalt))
import Test.ChasingBottoms.IsBottom
import Test.Framework (Test, defaultMain, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck (Arbitrary(arbitrary))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
-- Key type that generates more hash collisions.
newtype Key = K { unK :: Int }
deriving (Arbitrary, Eq, Ord, Show)
instance Hashable Key where
hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) =>
Arbitrary (HashMap k v) where
arbitrary = HM.fromList `fmap` arbitrary
instance Show (Int -> Int) where
show _ = "<function>"
instance Show (Int -> Int -> Int) where
show _ = "<function>"
------------------------------------------------------------------------
-- * Properties
------------------------------------------------------------------------
-- ** Strict module
pSingletonKeyStrict :: Int -> Bool
pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v
pSingletonValueStrict :: Key -> Bool
pSingletonValueStrict k = isBottom $ (HM.singleton k (bottom :: Int))
pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool
pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m
pLookupDefaultValueStrict :: Key -> HashMap Key Int -> Bool
pLookupDefaultValueStrict k m = isBottom $ HM.lookupDefault bottom k m
pAdjustKeyStrict :: (Int -> Int) -> HashMap Key Int -> Bool
pAdjustKeyStrict f m = isBottom $ HM.adjust f bottom m
pAdjustValueStrict :: Key -> HashMap Key Int -> Bool
pAdjustValueStrict k m
| k `HM.member` m = isBottom $ HM.adjust (const bottom) k m
| otherwise = case HM.keys m of
[] -> True
(k':_) -> isBottom $ HM.adjust (const bottom) k' m
pInsertKeyStrict :: Int -> HashMap Key Int -> Bool
pInsertKeyStrict v m = isBottom $ HM.insert bottom v m
pInsertValueStrict :: Key -> HashMap Key Int -> Bool
pInsertValueStrict k m = isBottom $ HM.insert k bottom m
pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> HashMap Key Int -> Bool
pInsertWithKeyStrict f v m = isBottom $ HM.insertWith f bottom v m
pInsertWithValueStrict :: (Int -> Int -> Int) -> Key -> Int -> HashMap Key Int
-> Bool
pInsertWithValueStrict f k v m
| HM.member k m = isBottom $ HM.insertWith (const2 bottom) k v m
| otherwise = isBottom $ HM.insertWith f k bottom m
------------------------------------------------------------------------
-- * Test list
tests :: [Test]
tests =
[
-- Basic interface
testGroup "HashMap.Strict"
[ testProperty "singleton is key-strict" pSingletonKeyStrict
, testProperty "singleton is value-strict" pSingletonValueStrict
, testProperty "member is key-strict" $ keyStrict HM.member
, testProperty "lookup is key-strict" $ keyStrict HM.lookup
, testProperty "lookupDefault is key-strict" pLookupDefaultKeyStrict
, testProperty "lookupDefault is value-strict" pLookupDefaultValueStrict
, testProperty "! is key-strict" $ keyStrict (flip (HM.!))
, testProperty "delete is key-strict" $ keyStrict HM.delete
, testProperty "adjust is key-strict" pAdjustKeyStrict
, testProperty "adjust is value-strict" pAdjustValueStrict
, testProperty "insert is key-strict" pInsertKeyStrict
, testProperty "insert is value-strict" pInsertValueStrict
, testProperty "insertWith is key-strict" pInsertWithKeyStrict
, testProperty "insertWith is value-strict" pInsertWithValueStrict
]
]
------------------------------------------------------------------------
-- * Test harness
main :: IO ()
main = defaultMain tests
------------------------------------------------------------------------
-- * Utilities
keyStrict :: (Key -> HashMap Key Int -> a) -> HashMap Key Int -> Bool
keyStrict f m = isBottom $ f bottom m
const2 :: a -> b -> c -> a
const2 x _ _ = x
Jump to Line
Something went wrong with that request. Please try again.