ixset-typed-0.3.1: tests/Data/IxSet/Typed/Tests.hs
{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, OverlappingInstances, UndecidableInstances, TemplateHaskell, DataKinds, FlexibleInstances, MultiParamTypeClasses, TypeOperators, KindSignatures #-}
{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-orphans #-}
-- TODO (only if SYBWC is added again):
-- Check that the SYBWC Data instance for IxSet works, by testing
-- that going to and from XML works.
module Data.IxSet.Typed.Tests where
import Control.Monad
import Control.Exception
import Data.Data (Data, Typeable)
import Data.IxSet.Typed as IxSet
import Data.Maybe
import qualified Data.Set as Set
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
data Foo
= Foo String Int
deriving (Eq, Ord, Show, Data, Typeable)
data FooX
= Foo1 String Int
| Foo2 Int
deriving (Eq, Ord, Show, Data, Typeable)
data NoIdxFoo
= NoIdxFoo Int
deriving (Eq, Ord, Show, Data, Typeable)
data BadlyIndexed
= BadlyIndexed Int
deriving (Eq, Ord, Show, Data, Typeable)
data MultiIndex
= MultiIndex String Int Integer (Maybe Int) (Either Bool Char)
| MultiIndexSubset Int Bool String
deriving (Eq, Ord, Show, Data, Typeable)
data Triple
= Triple Int Int Int
deriving (Eq, Ord, Show, Data, Typeable)
data S
= S String
deriving (Eq, Ord, Show, Data, Typeable)
data G a b
= G a b
deriving (Eq, Ord, Show, Data, Typeable)
fooCalcs :: Foo -> String
fooCalcs (Foo s _) = s ++ "bar"
inferIxSet "FooXs" ''FooX 'noCalcs [''Int, ''String]
inferIxSet "BadlyIndexeds" ''BadlyIndexed 'noCalcs [''String]
inferIxSet "MultiIndexed" ''MultiIndex 'noCalcs [''String, ''Int, ''Integer, ''Bool, ''Char]
inferIxSet "Triples" ''Triple 'noCalcs [''Int]
inferIxSet "Gs" ''G 'noCalcs [''Int]
inferIxSet "Foos" ''Foo 'fooCalcs [''String, ''Int]
instance Indexable '[Int] S where
indices = ixList (ixFun (\ (S x) -> [length x]))
ixSetCheckMethodsOnDefault :: TestTree
ixSetCheckMethodsOnDefault =
testGroup "check methods on default" $
[ testCase "size is zero" $
0 @=? size (IxSet.empty :: Foos)
, testCase "getOne returns Nothing" $
Nothing @=? getOne (IxSet.empty :: Foos)
, testCase "getOneOr returns default" $
Foo1 "" 44 @=? getOneOr (Foo1 "" 44) (IxSet.empty :: FooXs)
, testCase "toList returns []" $
[] @=? toList (IxSet.empty :: Foos)
]
foox_a :: FooX
foox_a = Foo1 "abc" 10
foox_b :: FooX
foox_b = Foo1 "abc" 20
foox_c :: FooX
foox_c = Foo2 10
foox_d :: FooX
foox_d = Foo2 20
foox_e :: FooX
foox_e = Foo2 30
foox_set_abc :: FooXs
foox_set_abc = insert foox_a $ insert foox_b $ insert foox_c $ IxSet.empty
foox_set_cde :: FooXs
foox_set_cde = insert foox_e $ insert foox_d $ insert foox_c $ IxSet.empty
ixSetCheckSetMethods :: TestTree
ixSetCheckSetMethods =
testGroup "check set methods" $
[ testCase "size abc is 3" $
3 @=? size foox_set_abc
, testCase "size cde is 3" $
3 @=? size foox_set_cde
, testCase "getOne returns Nothing" $
Nothing @=? getOne foox_set_abc
, testCase "getOneOr returns default" $
Foo1 "" 44 @=? getOneOr (Foo1 "" 44) foox_set_abc
, testCase "toList returns 3 element list" $
3 @=? length (toList foox_set_abc)
]
isError :: a -> Assertion
isError x = do
r <- try (return $! x)
case r of
Left (ErrorCall _) -> return ()
Right _ -> assertFailure $ "Exception expected, but call was successful."
-- TODO: deferred type error checks disabled for now, because unfortunately, they are
-- fragile to test for throughout different GHC versions
badIndexSafeguard :: TestTree
badIndexSafeguard =
testGroup "bad index safeguard" $
[ -- TODO: the following is no longer an error. find a replacement test?
-- testCase "check if there is error when no first index on value" $
-- isError (size (insert (BadlyIndexed 123) empty :: BadlyIndexeds)) -- TODO: type sig now necessary
-- TODO / GOOD: this is a type error now
-- testCase "check if indexing with missing index" $
-- isError (getOne (foox_set_cde @= True)) -- TODO: should actually verify it's a type error
]
testTriple :: TestTree
testTriple =
testGroup "Triple"
[ testCase "check if we can find element" $
1 @=? size ((insert (Triple 1 2 3) empty :: Triples) -- TODO: type sig now necessary
@= (1::Int) @= (2::Int))
]
instance Arbitrary Foo where
arbitrary = liftM2 Foo arbitrary arbitrary
instance (Arbitrary a, Indexable (ix ': ixs) a)
=> Arbitrary (IxSet (ix ': ixs) a) where
arbitrary = liftM fromList arbitrary
prop_sizeEqToListLength :: Foos -> Bool
prop_sizeEqToListLength ixset = size ixset == length (toList ixset)
sizeEqToListLength :: TestTree
sizeEqToListLength =
testProperty "size === length . toList" $ prop_sizeEqToListLength
prop_union :: Foos -> Foos -> Bool
prop_union ixset1 ixset2 =
toSet (ixset1 `union` ixset2) == toSet ixset1 `Set.union` toSet ixset2
prop_intersection :: Foos -> Foos -> Bool
prop_intersection ixset1 ixset2 =
toSet (ixset1 `intersection` ixset2) ==
toSet ixset1 `Set.intersection` toSet ixset2
prop_any :: Foos -> [Int] -> Bool
prop_any ixset idxs =
(ixset @+ idxs) == foldr union empty (map ((@=) ixset) idxs)
prop_all :: Foos -> [Int] -> Bool
prop_all ixset idxs =
(ixset @* idxs) == foldr intersection ixset (map ((@=) ixset) idxs)
setOps :: TestTree
setOps = testGroup "set operations" $
[ testProperty "distributivity toSet / union" $ prop_union
, testProperty "distributivity toSet / intersection" $ prop_intersection
, testProperty "any (@+)" $ prop_any
, testProperty "all (@*)" $ prop_all
]
prop_opers :: Foos -> Int -> Bool
prop_opers ixset intidx =
and [ (lt `union` eq) == lteq
, (gt `union` eq) == gteq
-- this works for Foo as an Int field is in every Foo value
, (gt `union` eq `union` lt) == ixset
-- , (neq `intersection` eq) == empty
]
where
-- neq = ixset @/= intidx
eq = ixset @= intidx
lt = ixset @< intidx
gt = ixset @> intidx
lteq = ixset @<= intidx
gteq = ixset @>= intidx
opers :: TestTree
opers = testProperty "query operators" $ prop_opers
prop_sureelem :: Foos -> Foo -> Bool
prop_sureelem ixset foo@(Foo _string intidx) =
not (IxSet.null eq ) &&
not (IxSet.null lteq) &&
not (IxSet.null gteq)
where
ixset' = insert foo ixset
eq = ixset' @= intidx
lteq = ixset' @<= intidx
gteq = ixset' @>= intidx
sureelem :: TestTree
sureelem = testProperty "query / insert interaction" $ prop_sureelem
prop_ranges :: Foos -> Int -> Int -> Bool
prop_ranges ixset intidx1 intidx2 =
((ixset @>< (intidx1,intidx2)) == (gt1 &&& lt2)) &&
((ixset @>=< (intidx1,intidx2)) == ((gt1 ||| eq1) &&& lt2)) &&
((ixset @><= (intidx1,intidx2)) == (gt1 &&& (lt2 ||| eq2))) &&
((ixset @>=<= (intidx1,intidx2)) == ((gt1 ||| eq1) &&& (lt2 ||| eq2)))
where
eq1 = ixset @= intidx1
_lt1 = ixset @< intidx1
gt1 = ixset @> intidx1
eq2 = ixset @= intidx2
lt2 = ixset @< intidx2
_gt2 = ixset @> intidx2
ranges :: TestTree
ranges = testProperty "ranges" $ prop_ranges
funSet :: IxSet '[Int] S
funSet = IxSet.fromList [S "", S "abc", S "def", S "abcde"]
funIndexes :: TestTree
funIndexes =
testGroup "ixFun indices" $
[ testCase "has zero length element" $
1 @=? size (funSet @= (0 :: Int))
, testCase "has two lengh 3 elements" $
2 @=? size (funSet @= (3 :: Int))
, testCase "has three lengh [3;7] elements" $
3 @=? size (funSet @>=<= (3 :: Int, 7 :: Int))
]
bigSet :: Int -> MultiIndexed
bigSet n = fromList $
[ MultiIndex string int integer maybe_int either_bool_char |
string <- ["abc", "def", "ghi", "jkl"],
int <- [1..n],
integer <- [10000..10010],
maybe_int <- [Nothing, Just 5, Just 6],
either_bool_char <- [Left True, Left False, Right 'A', Right 'B']] ++
[ MultiIndexSubset int bool string |
string <- ["abc", "def", "ghi"],
int <- [1..n],
bool <- [True, False]]
findElementX :: MultiIndexed -> Int -> Bool
findElementX set n = isJust $ getOne (set @+ ["abc","def","ghi"]
@>=<= (10000 :: Integer,10010 :: Integer)
@= (True :: Bool)
@= (n `div` n)
@= "abc"
@= (10000 :: Integer)
@= (5 :: Int))
findElement :: Int -> Int -> Bool
findElement n m = all id ([findElementX set k | k <- [1..n]])
where set = bigSet m
multiIndexed :: TestTree
multiIndexed =
testGroup "MultiIndexed" $
[ testCase "find an element" (True @=? findElement 1 1)
]
allTests :: TestTree
allTests =
testGroup "ixset-typed tests" $
[ testGroup "unit tests" $
[ ixSetCheckMethodsOnDefault
, ixSetCheckSetMethods
, badIndexSafeguard
, multiIndexed
, testTriple
, funIndexes
]
, testGroup "properties" $
[ sizeEqToListLength
, setOps
, opers
, sureelem
, ranges
]
]