PathTree-0.1.1.0: test/Spec.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Test.QuickCheck
import Data.List (foldl')
import Control.Arrow (first)
import Control.Monad (liftM2, liftM3)
import Data.LCRSTree
import Data.PathTree
import Test.Framework
import Test.Framework.Providers.QuickCheck2
main :: IO ()
main = defaultMain runTests
runTests :: [Test]
runTests =
[ prop_fromPath
, prop_insert
, prop_pathExistance
, prop_roseIdentity
-- , testProperty "Tree Identity" $ noShrinking prop_identity
]
prop_fromPath :: Test
prop_fromPath =
testGroup "fromPath"
[ testProperty "identity" idendity_test
, testProperty "depth" depth_test
]
where
idendity_test :: Property
idendity_test =
forAll pathOf2OrMore $ \path ->
(head . toPaths . fromPath) path === path
depth_test =
forAll pathOf2OrMore $ \path ->
let depth = length path - 1
in lcrsDepth (fromPath path) === depth
pathOf2OrMore = nonEmptyPath `suchThat` ((2 <) . length)
prop_insert :: Test
prop_insert =
testGroup "Insert"
[ testProperty "all values inserted should exist in the tree" insertExists
, testProperty "inserting multiple paths with the same head should return a top node" topNodeInsert
, testProperty "two paths inserted in any order should both exist" insertOrderExist
, testProperty "inserting two path that diverge on a node should create a tree with one node diverging" insertDiverge
]
where
insertExists =
forAll nonEmptyPathAndTree $ \(path, tree) ->
let newT = insert path tree
in pathExistsE path newT
where
nonEmptyPathAndTree = liftM2 (,) nonEmptyPath arbitrary
insertOrderExist =
forAll twoNonEmptyPathsAndTree $ \(p1, p2, tree) ->
let newTree1 = insert p1 $ insert p2 tree
newTree2 = insert p2 $ insert p1 tree
in conjoin [ pathExistsE p1 newTree1, pathExistsE p2 newTree1
, pathExistsE p1 newTree2, pathExistsE p2 newTree2 ]
where
twoNonEmptyPathsAndTree :: Gen ([AlphaChar], [AlphaChar], LCRSTree AlphaChar)
twoNonEmptyPathsAndTree =
liftM3 (,,) (listOf1 arbitrary) (listOf1 arbitrary) arbitrary
topNodeInsert =
forAll nonEmptyPathAndArb $ \(paths, top) ->
let newPaths = map (top:) paths
tree = foldl' (flip insert) Empty newPaths
in siblings tree == Empty
where
siblings (Node _ _ s) = s
siblings (Leaf _ s) = s
sibling Empty = error "No siblings for Empty"
nonEmptyPathAndArb = liftM2 (,) (listOf1 nonEmptyPath) arbitrary
insertDiverge =
forAll (zipM3 nonEmptyPath nonEmptyPath nonEmptyPath) $ \(root, p1, p2) ->
let paths = [root ++ p1, root ++ p2]
lenOfInter = lenMin p1 p2
tree = foldl' (flip insert) Empty paths
actual = nodeCount tree
expectedNumOfLeaf = 2
expectedNumOfNode = lenOfInter - expectedNumOfLeaf + length root
in counterexample
(show tree ++ " contains " ++ show actual ++ " node-leaf count but expected "
++ show (expectedNumOfNode, expectedNumOfLeaf))
(actual == (expectedNumOfNode, expectedNumOfLeaf))
where
lenMin [l] a = 1 + length a
lenMin a [l] = 1 + length a
lenMin l1@(h1:t1) l2@(h2:t2)
| h1 == h2 = 1 + lenMin t1 t2
| otherwise = length $ l1 ++ l2
intersectFromStart a [] = a
intersectFromStart [] a = a
intersectFromStart l1@(h1:t1) l2@(h2:t2)
| h1 == h2 = h1 : intersectFromStart t1 t2
| otherwise = l1 ++ l2
prop_pathExistance :: Test
prop_pathExistance =
testGroup "Path integrity"
[ testProperty "paths should exist in a tree they make" prop_existance
, testProperty "countPathExistances should return n for n non-uniquily inserted paths" prop_cpeNonUnique
, testProperty "countPathExistances should return 1 for n uniquily inserted paths" prop_cpeUnique
]
where
nonZero :: Gen Int
nonZero = arbitrary `suchThat` (>0)
prop_existance =
forAll (listOf1 nonEmptyPath) $ \paths ->
let tr = fromPaths paths
in conjoin $ map (`pathExistsE` tr) paths
prop_cpeNonUnique =
forAll (zipM nonEmptyPath nonZero) $ \(path, n) ->
let tr = foldl' (flip insert) Empty $ map (const path) [1..n]
in countPathExistances path tr === n
prop_cpeUnique =
forAll (zipM nonEmptyPath nonZero) $ \(path, n) ->
let tr = foldl' (flip insertReplace) Empty $ map (const path) [1..n]
in countPathExistances path tr === 1
prop_roseIdentity :: Test
prop_roseIdentity =
testProperty "fromRoseTree . toRoseTree should be identity" roseIdent
where
roseIdent :: LCRSTree AlphaChar -> Property
roseIdent tree = (fromRoseTree . toRoseTree) tree === tree
-- I would like to test this, but at the moment, I can't guarantee the
-- order in which the tree is built from the path will be the same
-- other the tree had before. Semantically speaking, however, the tree
-- doesn't change.
--
-- I could make the equality if the tree be order independent on
-- sibling nodes, but that sounds like work :\
-- We could use the path as the "identity" of a tree (a tree is indentified
-- by its paths). This makes sense, I think.
prop_identity :: LCRSTree AlphaChar -> Property
prop_identity tree = (fromPaths . toPaths) tree === tree
instance (Eq n, Arbitrary n) => Arbitrary (LCRSTree n) where
shrink Empty = []
shrink (Leaf a s) =
[Empty] ++ [s] ++ [Leaf a' s' | (a', s') <- shrink (a, s)]
shrink (Node n c s) =
[Empty] ++ [c, s] ++ [Node n' c' s' | (n', c', s') <- shrink (n, c, s)]
arbitrary = do
let empty = return Empty
leaf = do n <- arbitrary
s <- freq [empty, node, leaf]
return $ Leaf n s
node = do n <- arbitrary
c <- freq [leaf, node]
s <- freq [empty, leaf, node]
return $ Node n c s
n <- arbitrary
c <- node
return $ Node n c Empty
where
freq = frequency . freq' 60
where
freq' _ [] = []
freq' n (h:t)
| n <= 1 = (1, h) : freq' 1 t
| otherwise = (n, h) : freq' (div n 2) t
-- | A smaller set of characters (a-zA-Z)
newtype AlphaChar = AlphaChar Char
deriving (Eq, Ord)
instance Show AlphaChar where
show (AlphaChar c) = "'" ++ [c] ++ "'"
instance Arbitrary AlphaChar where
arbitrary =
let es = elements $ ['A'..'Z'] ++ ['a'..'z']
in fmap AlphaChar es
zipM = liftM2 (,)
zipM3 = liftM3 (,,)
pathExistsE x y =
counterexample (show x ++ " does not exist in " ++ show y) (pathExists x y)
nonEmptyPath :: Gen [AlphaChar]
nonEmptyPath = arbitrary `suchThat` (not . null)
countPathExistances :: (Integral i, Eq n) => [n] -> PathTree n -> i
countPathExistances [] _ = 1 -- The empty path exists once, in any tree
countPathExistances _ Empty = 0
countPathExistances [h] (Leaf n s)
| h == n = 1 + countPathExistances [h] s
| otherwise = countPathExistances [h] s
countPathExistances (h:t) tree =
case tree of
Empty -> 0
Leaf _ s -> countPathExistances (h:t) s
Node n c s -> if n == h
then countPathExistances t c
else countPathExistances (h:t) s
nodeCount :: Integral i => PathTree n -> (i, i)
nodeCount = nodeC (0,0)
where
nodeC :: Integral i => (i, i) -> PathTree n -> (i, i)
nodeC t Empty = t
nodeC (cn, cl) (Leaf _ s) = nodeC (cn, cl + 1) s
nodeC (cn, cl) (Node _ c s) =
let (cnc, clc) = nodeC (cn + 1, cl) c
(snc, slc) = nodeC (0, 0) s
in (cnc + snc, clc + slc)