text-trie-0.2.5.0: test/Data/Trie/Text/Test.hs
{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-orphans #-}
{-# LANGUAGE CPP
, MultiParamTypeClasses
, FlexibleInstances
, FlexibleContexts
, TypeSynonymInstances
#-}
{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
----------------------------------------------------------------
-- ~ 2019.04.03
-- |
-- Module : Data.Trie.Test
-- Copyright : Copyright (c) 2008--2015 wren gayle romano, 2019 michael j. klein
-- License : BSD3
-- Maintainer : lambdamichael@gmail.com
-- Stability : experimental
--
-- Testing 'Trie's.
----------------------------------------------------------------
module Data.Trie.Text.Test (test) where
import qualified Data.Trie.Text as Tr
import qualified Data.Trie.Text.Convenience as TC
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import Data.Text.Internal.Word16 (toList16, length16)
import qualified Test.HUnit as HU
import qualified Test.QuickCheck as QC
import qualified Test.QuickCheck.Arbitrary as QCA
import qualified Test.SmallCheck as SC
import qualified Test.SmallCheck.Series as SCS
-- import qualified Test.LazySmallCheck as LSC
-- import qualified Test.SparseCheck as PC
import Data.Function
import Data.List (nubBy, sortOn)
import GHC.Generics
import System.IO.Silently (capture)
----------------------------------------------------------------
----------------------------------------------------------------
----------------------------------------------------------------
deriving instance Generic Int
test :: IO ()
test = do
putStrLn ""
putStrLn (replicate 80 '~')
putStrLn "hunit:"
_ <- HU.runTestTT $ HU.TestList
[ test_Union
, test_Submap
, test_Insert
, test_Delete
]
putStrLn ""
putStrLn "quickcheck @ Int (Text):"
putStrLn "prop_insert"
checkQuick 500 (prop_insert :: Str -> Int -> Tr.Trie Int -> Bool)
putStrLn "prop_singleton"
checkQuick 5000 (prop_singleton :: Str -> Int -> Bool)
putStrLn "prop_size_insert"
checkQuick 500 (prop_size_insert :: Str -> Int -> Tr.Trie Int -> QC.Property)
putStrLn "prop_size_delete"
checkQuick 500 (prop_size_delete :: Str -> Int -> Tr.Trie Int -> QC.Property)
putStrLn "prop_insert_delete"
checkQuick 500 (prop_insert_delete :: Str -> Int -> Tr.Trie Int -> QC.Property)
putStrLn "prop_delete_lookup"
checkQuick 500 (prop_delete_lookup :: Str -> Tr.Trie Int -> QC.Property)
putStrLn "prop_submap1"
checkQuick 500 (prop_submap1 :: Str -> Tr.Trie Int -> Bool)
putStrLn "prop_submap2"
checkQuick 500 (prop_submap2 :: Str -> Tr.Trie Int -> Bool)
putStrLn "prop_submap3"
checkQuick 500 (prop_submap3 :: Str -> Tr.Trie Int -> Bool)
putStrLn "prop_toList"
checkQuick 500 (prop_toList :: Tr.Trie Int -> QC.Property)
putStrLn "prop_fromList_takes_first"
checkQuick 500 (prop_fromList_takes_first :: [(Str, Int)] -> QC.Property)
putStrLn "prop_fromListR_takes_first"
checkQuick 500 (prop_fromListR_takes_first :: [(Str, Int)] -> QC.Property)
putStrLn "prop_fromListL_takes_first"
checkQuick 500 (prop_fromListL_takes_first :: [(Str, Int)] -> QC.Property)
putStrLn "prop_fromListS_takes_first"
checkQuick 500 (prop_fromListS_takes_first :: [(Str, Int)] -> QC.Property)
putStrLn "prop_fromListWithConst_takes_first"
checkQuick 500 (prop_fromListWithConst_takes_first :: [(Str, Int)] -> QC.Property)
putStrLn "prop_fromListWithLConst_takes_first"
checkQuick 500 (prop_fromListWithLConst_takes_first :: [(Str, Int)] -> QC.Property)
putStrLn ""
putStrLn "prop_length16_is_length_toList16"
checkQuick 500 (prop_length16_is_length_toList16 :: Str -> QC.Property)
putStrLn ""
putStrLn "smallcheck @ () (Text):" -- Beware the exponential!
putStrLn "prop_insert"
checkSmall 3 (prop_insert :: Str -> () -> Tr.Trie () -> Bool)
putStrLn "prop_singleton"
checkSmall 7 (prop_singleton :: Str -> () -> Bool)
putStrLn "prop_size_insert"
checkSmall 3 (prop_size_insert :: Str -> () -> Tr.Trie () -> SC.Property IO)
putStrLn "prop_size_delete"
checkSmall 3 (prop_size_delete :: Str -> () -> Tr.Trie () -> SC.Property IO)
putStrLn "prop_insert_delete"
checkSmall 3 (prop_insert_delete :: Str -> () -> Tr.Trie () -> SC.Property IO)
putStrLn "prop_delete_lookup"
checkSmall 3 (prop_delete_lookup :: Str -> Tr.Trie () -> SC.Property IO)
putStrLn "prop_submap1"
checkSmall 3 (prop_submap1 :: Str -> Tr.Trie () -> Bool)
putStrLn "prop_submap2"
checkSmall 3 (prop_submap2 :: Str -> Tr.Trie () -> Bool)
putStrLn ""
where
#ifdef __USE_QUICKCHECK_1__
checkQuick n =
QC.check (QC.defaultConfig
{ QC.configMaxTest = n
, QC.configMaxFail = 1000 `max` 10*n
})
#else
checkQuick n =
QC.quickCheckWith (QC.stdArgs
{ QC.maxSize = n
, QC.maxSuccess = n
, QC.maxDiscardRatio = 1000 `max` 10*n
})
#endif
checkSmall d f = SC.smallCheck d f >> putStrLn ""
testEqual :: (Show a, Eq a) => String -> a -> a -> HU.Test
testEqual s a b =
HU.TestLabel s $ HU.TestCase $ HU.assertEqual "" a b
----------------------------------------------------------------
-- Because we avoid epsilons everywhere else, need to make sure 'mergeBy' gets it right
test_Union :: HU.Test
test_Union = HU.TestLabel "epsilon union"
$ HU.TestList
[ testEqual "left" (e1 `Tr.unionL` e2) e1
, testEqual "right" (e1 `Tr.unionR` e2) e2 -- meh, why not
, testEqual "unionR regression" (tLeft `Tr.unionR` tRight) tRightResult
, testEqual "unionL regression" (tLeft `Tr.unionL` tRight) tLeftResult
]
where
e1 = Tr.singleton T.empty (4::Int)
e2 = Tr.singleton T.empty (2::Int)
-- Regression test against bug filed by Gregory Crosswhite on 2010.06.10 against version 0.2.1.1.
a, b :: T.Text
a = T.pack $ read "\"\231^\179\160Y\134Gr\158<)&\222\217#\156\""
b = T.pack $ read "\"\172\193\GSp\222\174GE\186\151\DC1#P\213\147\SI\""
tLeft = Tr.fromList [(a,1::Int),(b,0::Int)]
tRight = Tr.fromList [(a,2::Int)]
tRightResult = Tr.fromList [(a,2::Int),(b,0::Int)]
tLeftResult = Tr.fromList [(a,1::Int),(b,0::Int)]
----------------------------------------------------------------
test_Submap :: HU.Test
test_Submap = HU.TestLabel "submap"
$ HU.TestList
[ nullSubmap "split on arc fails" fi True
, nullSubmap "prefix of arc matches" fo False
, nullSubmap "suffix of empty fails" food True
, nullSubmap "missing branch fails" bag True
, nullSubmap "at a branch matches" ba False
]
where
t = vocab2trie ["foo", "bar", "baz"]
fi = T.pack "fi"
fo = T.pack "fo"
food = T.pack "food"
ba = T.pack "ba"
bag = T.pack "bag"
nullSubmap s q b = testEqual s (Tr.null $ Tr.submap q t) b
vocab2trie = Tr.fromList . flip zip [(0::Int)..] . map T.pack
----------------------------------------------------------------
-- requires Eq (Trie a) and, in case it fails, Show (Trie a)
test_Insert :: HU.Test
test_Insert = HU.TestLabel "insert"
$ HU.TestList
[ testEqual "insertion is commutative for prefix/superfix"
(Tr.insert aba o $ Tr.insert abaissed i $ Tr.empty)
(Tr.insert abaissed i $ Tr.insert aba o $ Tr.empty)
]
where
aba = T.pack "aba"
abaissed = T.pack "abaissed"
o = 0::Int
i = 1::Int
test_Delete :: HU.Test
test_Delete = HU.TestLabel "delete"
$ HU.TestList
[ testEqual "deleting epsilon from empty trie is empty"
(Tr.delete epsilon Tr.empty) (Tr.empty :: Tr.Trie Int)
]
where
epsilon = T.pack ""
newtype Letter = Letter { unLetter :: Char }
deriving (Eq, Ord, Show)
letters :: [Char]
letters =
concat
[ ['\t' .. '\n']
, [' ']
, ['"' .. '#']
, ['(' .. ')']
, ['+' .. ';']
, ['=', '?']
, ['A' .. 'Z']
, ['_']
, ['a' .. 'z']
, [ '\170'
, '\220'
, '\223'
, '\233'
, '\241'
, '\261'
, '\338'
, '\12354'
, '\12509'
, '\13312'
, '\19970'
, '\34920'
, '\36877'
, '\40407'
, '\65314'
, '\131072'
]
]
instance QCA.Arbitrary Letter where
arbitrary = Letter `fmap` QC.elements letters
shrink = fmap Letter . QCA.shrink . unLetter
newtype Str = Str { unStr :: L.Text }
deriving (Eq, Ord, Show)
instance QCA.Arbitrary Str where
arbitrary = QC.sized $ \n -> do
k <- QC.choose (0,n)
s <- QC.vector k
c <- QC.arbitrary -- We only want non-empty strings.
return . Str . L.pack $ map unLetter (c:s)
shrink = fmap Str . QCA.shrink . unStr
instance QCA.Arbitrary T.Text where
arbitrary = T.pack <$> QCA.arbitrary
shrink = fmap T.pack . QCA.shrink . T.unpack
instance QCA.Arbitrary L.Text where
arbitrary = L.pack <$> QCA.arbitrary
shrink = fmap L.pack . QCA.shrink . L.unpack
instance (QCA.Arbitrary a, Generic a) => QCA.Arbitrary (Tr.Trie a) where
arbitrary = QC.sized $ \n -> do
k <- QC.choose (0,n)
labels <- map (L.toStrict . unStr) `fmap` QC.vector k
elems <- QC.vector k
return . Tr.fromList $ zip labels elems
shrink = QCA.genericShrink
----------------------------------------------------------------
-- cf <http://www.cs.york.ac.uk/fp/darcs/smallcheck/README>
-- type Series a = Int -> [a]
instance Monad m => SCS.Serial m Letter where
series = SCS.generate $ \d -> take (d+1) $ map Letter letters
instance Monad m => SCS.Serial m Str where
series = Str . L.pack . map unLetter <$> SCS.series
-- -- TODO: This instance really needs some work. The smart constructures ensure only valid values are generated, but there are redundancies and inefficiencies.
instance (Monoid a, SCS.Serial m a) => SCS.Serial m (Tr.Trie a) where
series = SCS.cons0 Tr.empty
SCS.\/ SCS.cons3 arcHACK
SCS.\/ SCS.cons2 mappend
where
arcHACK (Str k) Nothing t = Tr.singleton (L.toStrict k) () >> t
arcHACK (Str k) (Just v) t = Tr.singleton (L.toStrict k) v
>>= Tr.unionR t . Tr.singleton T.empty
----------------------------------------------------------------
----------------------------------------------------------------
-- | If you insert a value, you can look it up
prop_insert :: (Eq a) => Str -> a -> Tr.Trie a -> Bool
prop_insert (Str k) v t =
(Tr.lookup sk . Tr.insert sk v $ t) == Just v
where
sk = L.toStrict k
-- | A singleton, is.
prop_singleton :: (Eq a) => Str -> a -> Bool
prop_singleton (Str k) v =
Tr.insert sk v Tr.empty == Tr.singleton sk v
where
sk = L.toStrict k
-- | Deal with QC/SC polymorphism issues because of (==>)
-- Fundeps would be nice here, but |b->a is undecidable, and |a->b is wrong
class CheckGuard a b where
(==>) :: Bool -> a -> b
instance (QC.Testable a) => CheckGuard a QC.Property where
(==>) = (QC.==>)
instance SC.Testable IO QC.Property where
test prop = SC.monadic $ do
(resultStr, result) <- capture $ checkQuick 500 prop
if QC.isSuccess result
then return True
else do
putStrLn resultStr
print result
return False
where
#ifdef __USE_QUICKCHECK_1__
checkQuick n =
QC.checkResult (QC.defaultConfig
{ QC.configMaxTest = n
, QC.configMaxFail = 1000 `max` 10*n
})
#else
checkQuick n =
QC.quickCheckWithResult (QC.stdArgs
{ QC.maxSize = n
, QC.maxSuccess = n
, QC.maxDiscardRatio = 1000 `max` 10*n
})
#endif
instance (Monad m, SC.Testable m a) => CheckGuard a (SC.Property m) where
(==>) = (SC.==>)
prop_size_insert :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> a -> Tr.Trie a -> b
prop_size_insert (Str k) v t = not (sk `Tr.member` t) ==> (
(Tr.size . Tr.insert sk v) === ((1+) . Tr.size)
$ t)
where
sk = L.toStrict k
prop_size_delete :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> a -> Tr.Trie a -> b
prop_size_delete (Str k) v t = not (sk `Tr.member` t) ==> (
(Tr.size . Tr.delete sk . Tr.insert sk v) === Tr.size
$ t)
where
sk = L.toStrict k
prop_insert_delete :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> a -> Tr.Trie a -> b
prop_insert_delete (Str k) v t = not (sk `Tr.member` t) ==> (
(Tr.delete sk . Tr.insert sk v) === id
$ t)
where
sk = L.toStrict k
prop_delete_lookup :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> Tr.Trie a -> b
prop_delete_lookup (Str k) t = not (sk `Tr.member` t) ==> (
(Tr.lookup sk . Tr.delete sk) === const Nothing
$ t)
where
sk = L.toStrict k
-- | All keys in a submap are keys in the supermap
prop_submap1 :: Str -> Tr.Trie a -> Bool
prop_submap1 (Str k) t =
all ((`Tr.member` t) . L.toStrict) . Tr.keys . Tr.submap (L.toStrict k) $ t
-- | All keys in a submap have the query as a prefix
prop_submap2 :: Str -> Tr.Trie a -> Bool
prop_submap2 (Str k) t =
all (L.isPrefixOf k) . Tr.keys . Tr.submap (L.toStrict k) $ t
-- | All values in a submap are the same in the supermap
prop_submap3 :: (Eq a) => Str -> Tr.Trie a -> Bool
prop_submap3 (Str k) t =
(\q -> Tr.lookup q t' == Tr.lookup q t) `all` fmap L.toStrict (Tr.keys t')
where t' = Tr.submap (L.toStrict k) t
infix 4 <==
(<==) :: (Ord a, Show a) => a -> a -> QC.Property
x <== y =
QC.counterexample (show x ++ interpret res ++ show y) (res == LT || res == EQ)
where
res = x `compare` y
interpret LT = " < "
interpret EQ = " == "
interpret GT = " > "
-- | Keys are ordered when converting to a list
prop_toList :: Tr.Trie a -> QC.Property
prop_toList t = ordered (toList16 . L.toStrict <$> Tr.keys t)
where ordered xs = QC.conjoin (zipWith (<==) xs (drop 1 xs))
_takes_first :: (Eq c, Show c) => ([(L.Text, c)] -> Tr.Trie c) -> [(Str, c)] -> QC.Property
_takes_first f assocs =
(Tr.toList . f) === (nubBy (apFst ((==) `on` (toList16 . L.toStrict))) . sortOn (toList16 . L.toStrict . fst))
$ map (first unStr) assocs
-- | 'fromList' takes the first value for a given key
prop_fromList_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property
prop_fromList_takes_first = _takes_first (Tr.fromList . fmap (first L.toStrict))
-- | 'fromListR' takes the first value for a given key
prop_fromListR_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property
prop_fromListR_takes_first = _takes_first (TC.fromListR . fmap (first L.toStrict))
-- | 'fromListL' takes the first value for a given key
prop_fromListL_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property
prop_fromListL_takes_first = _takes_first (TC.fromListL . fmap (first L.toStrict))
-- | 'fromListS' takes the first value for a given key
prop_fromListS_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property
prop_fromListS_takes_first = _takes_first (TC.fromListS . fmap (first L.toStrict))
-- | @('fromListWith' const)@ takes the first value for a given key
prop_fromListWithConst_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property
prop_fromListWithConst_takes_first = _takes_first (TC.fromListWith const . fmap (first L.toStrict))
-- | @('fromListWithL' const)@ takes the first value for a given key
prop_fromListWithLConst_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property
prop_fromListWithLConst_takes_first = _takes_first (TC.fromListWithL const . fmap (first L.toStrict))
prop_length16_is_length_toList16 :: Str -> QC.Property
prop_length16_is_length_toList16 = (length16 . L.toStrict . unStr) === (length . toList16 . L.toStrict . unStr)
----------------------------------------------------------------
-- | Lift a function to apply to the first of pairs, retaining the second.
first :: (a -> b) -> (a,c) -> (b,c)
first f (x,y) = (f x, y)
-- | Lift a binary function to apply to the first of pairs, discarding seconds.
apFst :: (a -> b -> c) -> ((a,d) -> (b,e) -> c)
apFst f (x,_) (y,_) = f x y
-- | Function equality
(===) :: (Eq b, Show b) => (a -> b) -> (a -> b) -> (a -> QC.Property)
(===) f g x = (QC.===) (f x) (g x)
----------------------------------------------------------------
----------------------------------------------------------- fin.