[#32] Add InsertLookup property test for PrefixTree

src/Toml/PrefixTree.hs

@@ -16,6 +16,7 @@ module Toml.PrefixTree
          -- * Types
        , Piece (..)
        , Key (..)
+       , pattern (:||)
        , Prefix
        , KeysDiff (..)
        ) where
@@ -77,6 +78,7 @@ data PrefixTree a
              , bVal        :: !(Maybe a)      -- ^ value by key = prefix
              , bPrefixMap  :: !(PrefixMap a)  -- ^ suffixes of prefix
              }
+    deriving (Show, Eq)
 
 data KeysDiff
       -- | Keys are equal

stack-8.0.2.yaml

@@ -3,5 +3,6 @@ resolver: lts-9.21
 extra-deps:
 - megaparsec-6.4.1
 - parser-combinators-0.4.0
+- tasty-hedgehog-0.2.0.0
 
 allow-newer: true

stack.yaml

@@ -1 +1 @@
-resolver: lts-11.0
+resolver: lts-11.7

test/Spec.hs

@@ -1,2 +1,8 @@
+module Main where
+
+import Test.Tasty (defaultMain)
+
+import Test.Toml.PrefixTree (prefixTreeTests)
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+main = prefixTreeTests >>= defaultMain

test/Test/Toml/PrefixTree.hs

@@ -0,0 +1,13 @@
+module Test.Toml.PrefixTree
+       ( prefixTreeTests
+       ) where
+
+import Test.Tasty (TestTree, testGroup)
+
+import Test.Toml.PrefixTree.Property (propertyTests)
+import Test.Toml.PrefixTree.Unit (unitTests)
+
+prefixTreeTests :: IO TestTree
+prefixTreeTests = do
+   uTests <- unitTests
+   pure $ testGroup "Prefix Tree tests" $ uTests : propertyTests

test/Test/Toml/PrefixTree/Property.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE PatternSynonyms     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test.Toml.PrefixTree.Property
+       ( propertyTests
+       ) where
+
+import Control.Monad (forM)
+
+import Hedgehog (MonadGen, Property, forAll, property, (===))
+import Test.Tasty (TestTree)
+import Test.Tasty.Hedgehog (testProperty)
+
+import Toml.PrefixTree (pattern (:||), Key (..), Piece (..), PrefixMap, PrefixTree (..))
+
+import qualified Data.HashMap.Strict as HashMap
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import qualified Toml.PrefixTree as Prefix
+
+propertyTests :: [TestTree]
+propertyTests = [insertLookup, insertInsert]
+
+insertLookup, insertInsert :: TestTree
+insertLookup = testProperty "lookup k (insert k v m) == Just v"     prop_InsertLookup
+insertInsert = testProperty "insert x a . insert x b == insert x a" prop_InsertInsert
+
+----------------------------------------------------------------------------
+-- Common generators
+----------------------------------------------------------------------------
+
+type V = Int
+
+genVal :: MonadGen m => m V
+genVal = Gen.int (Range.constant 0 256)
+
+genPiece :: MonadGen m => m Piece
+genPiece = Piece <$> Gen.text (Range.constant 1 50) Gen.unicode
+
+genKey :: MonadGen m => m Key
+genKey = Key <$> Gen.nonEmpty (Range.constant 1 10) genPiece
+
+-- Generates key-value pair for PrefixMap
+genEntry :: MonadGen m => m (Piece, Key)
+genEntry = do
+    key@(piece :|| _) <- genKey
+    pure (piece, key)
+
+genPrefixMap :: MonadGen m => m (PrefixMap V)
+genPrefixMap = do
+    entries <- Gen.list (Range.linear 0 10) genEntry
+    kvps    <- forM entries $ \(piece, key) -> do
+        tree <- genPrefixTree key
+        pure (piece, tree)
+
+    pure $ HashMap.fromList kvps
+
+genPrefixTree :: forall m . MonadGen m => Key -> m (PrefixTree V)
+genPrefixTree key = Gen.recursive
+    -- list picker generator combinator
+    Gen.choice
+    -- non-recursive generators
+    [ Leaf key <$> genVal ]
+    -- recursive generators
+    [ genPrefixMap >>= genBranch ]
+  where
+    genBranch :: PrefixMap V -> m (PrefixTree V)
+    genBranch prefMap = do
+        prefVal <- Gen.maybe genVal
+        pure $ Branch key prefVal prefMap
+
+----------------------------------------------------------------------------
+-- InsertLookup
+----------------------------------------------------------------------------
+
+prop_InsertLookup :: Property
+prop_InsertLookup =  property $ do
+    t   <- forAll genPrefixMap
+    key <- forAll genKey
+    val <- forAll genVal
+
+    Prefix.lookup key (Prefix.insert key val t) === Just val
+
+    -- DEBUG: ensures that trees of depth at least 5 are generated
+    -- assert $ depth prefMap < 5
+
+----------------------------------------------------------------------------
+-- InsertInsert
+----------------------------------------------------------------------------
+
+prop_InsertInsert :: Property
+prop_InsertInsert =  property $ do
+    t <- forAll genPrefixMap
+    x <- forAll genKey
+    a <- forAll genVal
+    b <- forAll genVal
+
+    Prefix.lookup x (Prefix.insert x a $ Prefix.insert x b t) === Just a
+
+----------------------------------------------------------------------------
+-- DEBUG
+----------------------------------------------------------------------------
+
+-- useful functions to test generators
+-- TODO: commented to avoid warnings
+
+-- depth :: PrefixMap a -> Int
+-- depth = HashMap.foldl' (\acc t -> max acc (depthT t)) 0
+--
+-- depthT :: PrefixTree a -> Int
+-- depthT (Leaf _ _)           = 1
+-- depthT (Branch _ _ prefMap) = 1 + depth prefMap

test/Test/Toml/PrefixTree/Unit.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE PatternSynonyms  #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Toml.PrefixTree.Unit
+       ( unitTests
+       ) where
+
+import Test.Tasty (TestTree)
+import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec)
+
+import Toml.PrefixTree (pattern (:||))
+
+import qualified Toml.PrefixTree as Prefix
+
+unitTests :: IO TestTree
+unitTests = testSpec "PrefixTree unit tests" spec_PrefixTree
+
+spec_PrefixTree :: Spec
+spec_PrefixTree = do
+  -- some test keys
+  let a  = "a" :|| []
+  let b  = "b" :|| []
+  let c  = "c" :|| []
+  let ab = "a" :|| ["b"]
+
+  describe "Insert and lookup unit tests" $ do
+    it "Lookup on empty map returns Nothing" $
+      Prefix.lookup @Bool a mempty `shouldBe` Nothing
+    it "Lookup in single map returns this element" $ do
+      let t = Prefix.single a True
+      Prefix.lookup a t `shouldBe` Just True
+      Prefix.lookup b t `shouldBe` Nothing
+    it "Lookup after insert returns this element" $ do
+      let t = Prefix.insert a True mempty
+      Prefix.lookup a t `shouldBe` Just True
+      Prefix.lookup b t `shouldBe` Nothing
+    it "Lookup after multiple non-overlapping inserts" $ do
+      let t = Prefix.insert a True $ Prefix.insert b False mempty
+      Prefix.lookup a t `shouldBe` Just True
+      Prefix.lookup b t `shouldBe` Just False
+      Prefix.lookup c t `shouldBe` Nothing
+    it "Prefix lookup" $ do
+      let t = Prefix.insert ab True mempty
+      Prefix.lookup a  t `shouldBe` Nothing
+      Prefix.lookup ab t `shouldBe` Just True
+    it "Composite key lookup" $ do
+      let t = Prefix.insert a True $ Prefix.insert ab False mempty
+      Prefix.lookup a  t `shouldBe` Just True
+      Prefix.lookup ab t `shouldBe` Just False

tomland.cabal

@@ -58,9 +58,21 @@ test-suite tomland-test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             Spec.hs
+  other-modules:       Test.Toml.PrefixTree
+                         Test.Toml.PrefixTree.Property
+                         Test.Toml.PrefixTree.Unit
+
   build-depends:       base
                      , tomland
-  ghc-options:         -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
+                     , hedgehog
+                     , tasty
+                     , tasty-hedgehog
+                     , tasty-hspec
+                     , text
+                     , unordered-containers
+
+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
+
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings
                        RecordWildCards