okasaki

commit 9c04fbbc50208de6c4dc4732acc20e085cd959bb
parent 0ba994d356688e72b4166a1a9b56121d2154b651
Author: Jared Tobin <jared@jtobin.io>
Date:   Wed, 15 Mar 2023 08:49:57 +0400

Tasty test harness.

Diffstat:
M
okasaki.cabal
 | 
12
++++++++++++
M
test/Heap/Leftist.hs
 | 
34
+++++++++++++++++++++++++---------
M
test/Heap/Weighted.hs
 | 
16
++++++++++++----
M
test/Main.hs
 | 
9
++++++++-

4 files changed, 57 insertions(+), 14 deletions(-)
diff --git a/okasaki.cabal b/okasaki.cabal
@@ -42,6 +42,16 @@ Test-suite tests
   hs-source-dirs:      test
   main-is:             Main.hs
   default-language:    Haskell2010
+  default-extensions:
+    DeriveFoldable
+    DeriveFunctor
+    DeriveTraversable
+    LambdaCase
+    RankNTypes
+    FlexibleInstances
+    TypeFamilies
+    TypeSynonymInstances
+    ViewPatterns
   other-modules:
      Heap.Leftist
    , Heap.Weighted
@@ -53,3 +63,5 @@ Test-suite tests
     , okasaki
     , QuickCheck
     , recursion-schemes
+    , tasty
+    , tasty-quickcheck
diff --git a/test/Heap/Leftist.hs b/test/Heap/Leftist.hs
@@ -1,12 +1,11 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 
 module Heap.Leftist (
-    leftist
+    decorated
+  , leftist
   , heap
+
+  , tests
   ) where
 
 import Control.Monad (foldM, replicateM)
@@ -14,13 +13,27 @@ import Data.Functor.Foldable (project, cata, para)
 import Data.Monoid
 import qualified Okasaki.Heap.Leftist as H
 import Test.QuickCheck
+import Test.Tasty (TestTree)
+import Test.Tasty.QuickCheck (testProperty)
+
+tests :: [TestTree]
+tests = [
+    testProperty "decorations accurate" decorated
+  , testProperty "leftist property invariant" leftist
+  , testProperty "heap order invariant" heap
+  ]
 
-lef :: H.Heap a -> Bool
-lef h = getSum (H.ran h) == cata alg h where
+dec :: H.Heap a -> Bool
+dec h = getSum (H.ran h) == cata alg h where
   alg = \case
     H.LeafF         -> 0
     H.NodeF _ _ _ r -> succ r
 
+wef :: H.Heap a -> Bool
+wef = para $ \case
+  H.LeafF -> True
+  H.NodeF _ _ (l, c) (r, d) -> H.ran l >= H.ran r && c && d
+
 hor :: Ord a => H.Heap a -> Bool
 hor = para $ \case
   H.LeafF -> True
@@ -48,7 +61,7 @@ use a h = case a of
 
 hep :: (Ord k, Arbitrary k) => Gen (H.Heap k)
 hep = do
-  num  <- choose (0, 10)
+  num  <- choose (0, 1000)
   acts <- replicateM num act
   foldM (flip use) H.lef acts
 
@@ -65,8 +78,11 @@ instance (Ord k, Arbitrary k) => Arbitrary (H.Heap k) where
   arbitrary = hep
   shrink = lil
 
+decorated :: Property
+decorated = forAllShrink (hep :: Gen (H.Heap Int)) lil dec
+
 leftist :: Property
-leftist = forAllShrink (hep :: Gen (H.Heap Int)) lil lef
+leftist = forAllShrink (hep :: Gen (H.Heap Int)) lil wef
 
 heap :: Property
 heap = forAllShrink (hep :: Gen (H.Heap Int)) lil hor
diff --git a/test/Heap/Weighted.hs b/test/Heap/Weighted.hs
@@ -1,13 +1,11 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 
 module Heap.Weighted (
     bleftist
   , decorated
   , heap
+
+  , tests
   ) where
 
 import Control.Monad (foldM, replicateM)
@@ -15,6 +13,16 @@ import Data.Fix (Fix(..))
 import Data.Functor.Foldable (project, para)
 import qualified Okasaki.Heap.Leftist.Weighted as H
 import Test.QuickCheck
+import Test.Tasty (TestTree)
+import Test.Tasty.QuickCheck (testProperty)
+
+tests :: [TestTree]
+tests = [
+    testProperty "decorations accurate" decorated
+  , testProperty "weight-biased leftist property invariant" bleftist
+  , testProperty "heap order invariant" heap
+  ]
+
 
 dec :: H.Heap a -> Bool
 dec h = H.siz h == H.wyt h
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,4 +1,11 @@
 module Main where
 
+import qualified Heap.Leftist as HL
+import qualified Heap.Weighted as HW
+import Test.Tasty (defaultMain, testGroup)
+
 main :: IO ()
-main = pure ()
+main = defaultMain $ testGroup "okasaki"
+  [ testGroup "leftist heap" HL.tests
+  , testGroup "weight-biased leftist heap" HW.tests
+  ]