{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where
import Test.ChasingBottoms.IsBottom
import Test.Framework (Test, TestName, defaultMain, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck (Arbitrary(arbitrary))
import Test.QuickCheck.Function (Fun(..), apply)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
import Data.Strict.IntMap.Autogen.Strict (IntMap)
import qualified Data.Strict.IntMap.Autogen.Strict as M
import qualified Data.IntMap.Lazy as L
import qualified Data.IntSet as IntSet
import Utils.IsUnit
instance Arbitrary v => Arbitrary (IntMap v) where
arbitrary = M.fromList `fmap` arbitrary
apply2 :: Fun (a, b) c -> a -> b -> c
apply2 f a b = apply f (a, b)
apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
apply3 f a b c = apply f (a, b, c)
------------------------------------------------------------------------
-- * Properties
------------------------------------------------------------------------
-- ** Strict module
pSingletonKeyStrict :: Int -> Bool
pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v
pSingletonValueStrict :: Int -> Bool
pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))
pFindWithDefaultKeyStrict :: Int -> IntMap Int -> Bool
pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m
pFindWithDefaultValueStrict :: Int -> IntMap Int -> Bool
pFindWithDefaultValueStrict k m =
M.member k m || (isBottom $ M.findWithDefault bottom k m)
pAdjustKeyStrict :: Fun Int Int -> IntMap Int -> Bool
pAdjustKeyStrict f m = isBottom $ M.adjust (apply f) bottom m
pAdjustValueStrict :: Int -> IntMap Int -> Bool
pAdjustValueStrict k m
| k `M.member` m = isBottom $ M.adjust (const bottom) k m
| otherwise = case M.keys m of
[] -> True
(k':_) -> isBottom $ M.adjust (const bottom) k' m
pInsertKeyStrict :: Int -> IntMap Int -> Bool
pInsertKeyStrict v m = isBottom $ M.insert bottom v m
pInsertValueStrict :: Int -> IntMap Int -> Bool
pInsertValueStrict k m = isBottom $ M.insert k bottom m
pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> IntMap Int -> Bool
pInsertWithKeyStrict f v m = isBottom $ M.insertWith (apply2 f) bottom v m
pInsertWithValueStrict :: Fun (Int, Int) Int -> Int -> Int -> IntMap Int
-> Bool
pInsertWithValueStrict f k v m
| M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&
not (isBottom $ M.insertWith (const2 1) k bottom m)
| otherwise = isBottom $ M.insertWith (apply2 f) k bottom m
pInsertLookupWithKeyKeyStrict :: Fun (Int, Int, Int) Int -> Int -> IntMap Int
-> Bool
pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey (apply3 f) bottom v m
pInsertLookupWithKeyValueStrict :: Fun (Int, Int, Int) Int -> Int -> Int
-> IntMap Int -> Bool
pInsertLookupWithKeyValueStrict f k v m
| M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&
not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)
| otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m
------------------------------------------------------------------------
-- test a corner case of fromAscList
--
-- If the list contains duplicate keys, then (only) the first of the
-- given values is not evaluated. This may change in the future, see
-- also https://github.com/haskell/containers/issues/473
pFromAscListLazy :: [Int] -> Bool
pFromAscListLazy ks = not . isBottom $ L.fromAscList elems
where
elems = [(k, v) | k <- nubInt ks, v <- [undefined, ()]]
pFromAscListStrict :: [Int] -> Bool
pFromAscListStrict ks
| null ks = not . isBottom $ M.fromAscList elems
| otherwise = isBottom $ M.fromAscList elems
where
elems = [(k, v) | k <- nubInt ks, v <- [undefined, undefined, ()]]
-- copy over definitions from Data.Containers.Utils so we can support older GHC
-- that have older versions of containers without this module
nubInt :: [Int] -> [Int]
nubInt = nubIntOn id
{-# INLINE nubInt #-}
nubIntOn :: (a -> Int) -> [a] -> [a]
nubIntOn f = \xs -> nubIntOnExcluding f IntSet.empty xs
{-# INLINE nubIntOn #-}
nubIntOnExcluding :: (a -> Int) -> IntSet.IntSet -> [a] -> [a]
nubIntOnExcluding f = go
where
go _ [] = []
go s (x:xs)
| fx `IntSet.member` s = go s xs
| otherwise = x : go (IntSet.insert fx s) xs
where !fx = f x
------------------------------------------------------------------------
-- check for extra thunks
--
-- These tests distinguish between `()`, a fully evaluated value, and
-- things like `id ()` which are extra thunks that should be avoided
-- in most cases. An exception is `L.fromListWith const`, which cannot
-- evaluate the `const` calls.
tExtraThunksM :: Test
tExtraThunksM = testGroup "IntMap.Strict - extra thunks" $
if not isUnitSupported then [] else
-- for strict maps, all the values should be evaluated to ()
[ check "singleton" $ m0
, check "insert" $ M.insert 42 () m0
, check "insertWith" $ M.insertWith const 42 () m0
, check "fromList" $ M.fromList [(42,()),(42,())]
, check "fromListWith" $ M.fromListWith const [(42,()),(42,())]
, check "fromAscList" $ M.fromAscList [(42,()),(42,())]
, check "fromAscListWith" $ M.fromAscListWith const [(42,()),(42,())]
, check "fromDistinctAscList" $ M.fromAscList [(42,())]
]
where
m0 = M.singleton 42 ()
check :: TestName -> IntMap () -> Test
check n m = testCase n $ case M.lookup 42 m of
Just v -> assertBool msg (isUnit v)
_ -> assertString "key not found"
where
msg = "too lazy -- expected fully evaluated ()"
tExtraThunksL :: Test
tExtraThunksL = testGroup "IntMap.Strict - extra thunks" $
if not isUnitSupported then [] else
-- for lazy maps, the *With functions should leave `const () ()` thunks,
-- but the other functions should produce fully evaluated ().
[ check "singleton" True $ m0
, check "insert" True $ L.insert 42 () m0
, check "insertWith" False $ L.insertWith const 42 () m0
, check "fromList" True $ L.fromList [(42,()),(42,())]
, check "fromListWith" False $ L.fromListWith const [(42,()),(42,())]
#if MIN_VERSION_containers(0,6,3)
-- see https://github.com/haskell/containers/issues/473
, check "fromAscList" True $ L.fromAscList [(42,()),(42,())]
#endif
, check "fromAscListWith" False $ L.fromAscListWith const [(42,()),(42,())]
, check "fromDistinctAscList" True $ L.fromAscList [(42,())]
]
where
m0 = L.singleton 42 ()
check :: TestName -> Bool -> L.IntMap () -> Test
check n e m = testCase n $ case L.lookup 42 m of
Just v -> assertBool msg (e == isUnit v)
_ -> assertString "key not found"
where
msg | e = "too lazy -- expected fully evaluated ()"
| otherwise = "too strict -- expected a thunk"
------------------------------------------------------------------------
-- * Test list
tests :: [Test]
tests =
[
-- Basic interface
testGroup "IntMap.Strict"
[ testProperty "singleton is key-strict" pSingletonKeyStrict
, testProperty "singleton is value-strict" pSingletonValueStrict
, testProperty "member is key-strict" $ keyStrict M.member
, testProperty "lookup is key-strict" $ keyStrict M.lookup
, testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict
, testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict
, testProperty "! is key-strict" $ keyStrict (flip (M.!))
, testProperty "!? is key-strict" $ keyStrict (flip (M.!?))
, testProperty "delete is key-strict" $ keyStrict M.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
, testProperty "insertLookupWithKey is key-strict"
pInsertLookupWithKeyKeyStrict
, testProperty "insertLookupWithKey is value-strict"
pInsertLookupWithKeyValueStrict
, testProperty "fromAscList is somewhat value-lazy" pFromAscListLazy
, testProperty "fromAscList is somewhat value-strict" pFromAscListStrict
]
, tExtraThunksM
, tExtraThunksL
]
------------------------------------------------------------------------
-- * Test harness
main :: IO ()
main = defaultMain tests
------------------------------------------------------------------------
-- * Utilities
keyStrict :: (Int -> IntMap Int -> a) -> IntMap Int -> Bool
keyStrict f m = isBottom $ f bottom m
const2 :: a -> b -> c -> a
const2 x _ _ = x
const3 :: a -> b -> c -> d -> a
const3 x _ _ _ = x