Fine tune the tree generator and add more awesome

level00/ExampleModelProperties.hs

@@ -4,8 +4,8 @@ import Hedgehog (MonadGen, PropertyT, Property, property, forAll, (===), withTes
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
+import Data.Map (Map)
+import qualified Data.Map as Map
 
 import MyBTree
 

level00/MyBTree.hs

@@ -8,13 +8,15 @@ module MyBTree
   , deleteKey
   , fromList
   , toListWithKey
+  , keys
+  , valid
   ) where
 
 import GHC.Generics
 import Data.Foldable (foldl')
 import Hedgehog.Function
 
--- Data structure and functions inspired by a presentation by John Hughes: "Building on developer intuitions". 
+-- Data structure and functions inspired by a presentation by John Hughes: "Building on developer intuitions".
 -- Which may be viewed at: https://www.youtube.com/watch?v=NcJOiQlzlXQ
 --
 
@@ -33,6 +35,17 @@ toListWithKey :: MyBTree k a -> [(k,a)]
 toListWithKey Empty         = []
 toListWithKey (Node l kv r) = toListWithKey l <> [kv] <> toListWithKey r
 
+keys :: MyBTree k a -> [k]
+keys = fmap fst . toListWithKey
+
+valid :: Ord k => MyBTree k a -> Bool
+valid Empty = True
+valid (Node l (k,_) r) =
+  valid l &&            -- left branch is a valid tree
+  valid r &&            -- right branch is a valid tree
+  all (< k) (keys l) && -- keys to the left are less than the current key
+  all (> k) (keys r)    -- keys to the right are greater than the current key
+
 insert :: Ord k => k -> a -> MyBTree k a -> MyBTree k a
 insert k v t = case t of
   Empty -> Node Empty (k, v) Empty

level00/PropertyTests.hs

@@ -109,17 +109,37 @@ prop_addCoins_Combined = error "prop_addCoins not implemented"
 -- These examples are lifted from a presentation by John Hughes: "Building on developer intuitions".
 -- Which may be viewed at: https://www.youtube.com/watch?v=NcJOiQlzlXQ
 
--- To test our assumptions, we'll need to generate random MyBTrees. Using the
--- constructor functions from the MyBTree module, write a generator that can use
--- a given generator to populate the tree.
-genTree :: (Ord k, MonadGen m) => m (k,v) -> m (MyBTree k v)
-genTree genKV = fromList <$> Gen.list (Range.linear 0 100) genKV
+-- To test our assumptions, we'll need to generate random MyBTrees.
+-- Use the constructors from the MyBTree module and write a
+-- generator for MyBTrees.
+genTree0 :: (Ord k, MonadGen g) => g k -> g v -> g (MyBTree k v)
+genTree0 genK genV = Gen.recursive Gen.choice
+  -- Non-recursive component of our tree
+  [ Gen.constant Empty ]
+  -- Recursive component of our tree
+  [ nodeGen ]
+  where
+    nodeGen = do
+      k <- genK
+      v <- genV
+      let
+        genLK = Gen.filter (< k) genK
+        genRK = Gen.filter (> k) genK
+
+      Gen.subterm2 (genTree0 genLK genV) (genTree0 genRK genV) (\l r -> Node l (k,v) r)
+
+genTree :: (Ord k, MonadGen m) => (m k, m v) -> m (MyBTree k v)
+genTree = uncurry genTree0
 
 -- To populate our tree, we need to generate some keys and their respective
 -- values. We will make Hedgehog do this for us by reusing some of the built-in
 -- generators.
-genMyBTreeVal :: MonadGen m => m (Int, Char)
-genMyBTreeVal = liftA2 (,) (Gen.int (Range.linear (-100) 100)) (Gen.enum 'a' 'z')
+genMyBTreeVal :: MonadGen m => (m Int, m Char)
+genMyBTreeVal = (Gen.int (Range.linear 0 1000), Gen.enum 'a' 'z')
+
+-- Confirm that we're generating valid data
+prop_tree_gen_valid :: Property
+prop_tree_gen_valid = property $ forAll (genTree genMyBTreeVal) >>= assert . valid
 
 -- We can also use property based testing to ensure that when we
 -- implement a typeclass instance, that implementation will comply
@@ -166,11 +186,11 @@ prop_MyBTree_LawfulEqInstance = property $ do
   let
     genKey = Gen.int (Range.linear (-100) 100)
     genVal = Gen.int (Range.linear 200 500)
-    genIntTree = genTree $ liftA2 (,) genKey genVal
+    genIntTree = genTree0 genKey genVal
 
   (i,j) <- forAll $ liftA2 (,) genIntTree genIntTree
   -- This generates a function of the following type: 'g :: MyBTree Int Int -> Bool'
-  g <- Fn.forAllFn $ Fn.fn @(MyBTree Int Int) Gen.bool 
+  g <- Fn.forAllFn $ Fn.fn @(MyBTree Int Int) Gen.bool
 
   annotate "Substitutivity: if x == y = True and g is a function whose return type is an instance of Eq, then g x == g y = True"
   when (i == j) $ (g i == g j) === True
@@ -222,6 +242,7 @@ propertyTests = testGroup "Level00 - Property Tests"
   , testProperty "BST delete" prop_MyBTree_Delete
 
   , testProperty "Using intended Eq instance implementation" prop_desired_eq_instance
+  , testProperty "MyBTree generator is valid" prop_tree_gen_valid
   ]
 
 ----------------------------------------------------------------------
@@ -234,7 +255,7 @@ propertyTests = testGroup "Level00 - Property Tests"
 prop_desired_eq_instance :: Property
 prop_desired_eq_instance = withTests 1 . property $ do
   let
-    kvs = [(1,'a'), (2, 'b'), (3, 'c')]
+    kvs = [(1,'a'), (2, 'b'), (3, 'c')] :: [(Int,Char)]
     kvsDiffVal = [(1,'a'), (2, 'd'), (3, 'c')]
     kvsDiffKey = [(1,'a'), (2, 'b'), (5, 'c')]
 

state-machine-testing-course.cabal

@@ -29,6 +29,7 @@ common level-setup
                      , lens > 4.15 && < 4.18
                      , tasty >= 1.1 && < 1.3
                      , tasty-hedgehog >= 0.2 && < 0.3
+                     , containers
 
 library
   exposed-modules:     CoffeeMachine
@@ -50,6 +51,7 @@ test-suite level00
                      , lens > 4.15 && < 4.18
                      , tasty >= 1.1 && < 1.3
                      , tasty-hedgehog >= 0.2 && < 0.3
+                     , containers
 
   other-modules:       PropertyTests
                      , MyBTree

state-machine-testing-course.nix

@@ -1,13 +1,13 @@
-{ mkDerivation, base, hedgehog, hedgehog-fn, lens, mtl, stdenv
-, tasty, tasty-hedgehog
+{ mkDerivation, base, containers, hedgehog, hedgehog-fn, lens, mtl
+, stdenv, tasty, tasty-hedgehog
 }:
 mkDerivation {
   pname = "state-machine-testing-course";
   version = "0.1.0.0";
   src = ./.;
   libraryHaskellDepends = [ base lens mtl ];
   testHaskellDepends = [
-    base hedgehog hedgehog-fn lens tasty tasty-hedgehog
+    base containers hedgehog hedgehog-fn lens tasty tasty-hedgehog
   ];
   description = "Introductory course for property-based state-machine testing";
   license = stdenv.lib.licenses.bsd3;