{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.Ledger.Tables.Diff (
    lawsTestOne
  , tests
  ) where

import           Data.Foldable as F
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import           Data.Typeable
import           Ouroboros.Consensus.Ledger.Tables.Diff
import           Test.QuickCheck.Classes
import           Test.Tasty (TestTree, testGroup)
import           Test.Tasty.QuickCheck hiding (Negative, Positive)
import           Test.Util.QuickCheck (le)

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Test.Consensus.Ledger.Tables.Diff" [
      TestName -> [TestTree] -> TestTree
testGroup TestName
"quickcheck-classes" [
          Proxy (Diff Int V) -> [Proxy (Diff Int V) -> Laws] -> TestTree
forall a. Typeable a => Proxy a -> [Proxy a -> Laws] -> TestTree
lawsTestOne (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Diff K V)) [
              Proxy (Diff Int V) -> Laws
forall a.
(Semigroup a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Laws
semigroupLaws
            , Proxy (Diff Int V) -> Laws
forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
monoidLaws
            ]
        ]
    , TestName -> [TestTree] -> TestTree
testGroup TestName
"Applying diffs" [
          TestName -> (Map Int V -> Map Int V -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"prop_diffThenApply" Map Int V -> Map Int V -> Property
prop_diffThenApply
        , TestName -> (Map Int V -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"prop_applyMempty" Map Int V -> Property
prop_applyMempty
        , TestName -> (Map Int V -> [Diff Int V] -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"prop_applySum" Map Int V -> [Diff Int V] -> Property
prop_applySum
        , TestName -> (Map Int V -> Diff Int V -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"prop_applyDiffNumInsertsDeletes"  Map Int V -> Diff Int V -> Property
prop_applyDiffNumInsertsDeletes
        , TestName -> (Map Int V -> Map Int V -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"prop_applyDiffNumInsertsDeletesExact" Map Int V -> Map Int V -> Property
prop_applyDiffNumInsertsDeletesExact
        ]
    ]

{------------------------------------------------------------------------------
  Running laws in test trees
------------------------------------------------------------------------------}

lawsTest :: Laws -> TestTree
lawsTest :: Laws -> TestTree
lawsTest Laws{TestName
lawsTypeclass :: TestName
lawsTypeclass :: Laws -> TestName
lawsTypeclass, [(TestName, Property)]
lawsProperties :: [(TestName, Property)]
lawsProperties :: Laws -> [(TestName, Property)]
lawsProperties} = TestName -> [TestTree] -> TestTree
testGroup TestName
lawsTypeclass ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
    ((TestName, Property) -> TestTree)
-> [(TestName, Property)] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TestName -> Property -> TestTree)
-> (TestName, Property) -> TestTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty) [(TestName, Property)]
lawsProperties

lawsTestOne :: Typeable a => Proxy a -> [Proxy a -> Laws] -> TestTree
lawsTestOne :: forall a. Typeable a => Proxy a -> [Proxy a -> Laws] -> TestTree
lawsTestOne Proxy a
p [Proxy a -> Laws]
tts =
    TestName -> [TestTree] -> TestTree
testGroup (TypeRep -> TestName
forall a. Show a => a -> TestName
show (TypeRep -> TestName) -> TypeRep -> TestName
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy a
p) (((Proxy a -> Laws) -> TestTree) -> [Proxy a -> Laws] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Proxy a -> Laws
f -> Laws -> TestTree
lawsTest (Laws -> TestTree) -> Laws -> TestTree
forall a b. (a -> b) -> a -> b
$ Proxy a -> Laws
f Proxy a
p) [Proxy a -> Laws]
tts)

{------------------------------------------------------------------------------
  Applying diffs
------------------------------------------------------------------------------}

type K = Int
type V = Char

-- | Applying a diff computed from a source and target value should
-- produce the target value.
prop_diffThenApply :: Map K V -> Map K V -> Property
prop_diffThenApply :: Map Int V -> Map Int V -> Property
prop_diffThenApply Map Int V
x Map Int V
y = Map Int V -> Diff Int V -> Map Int V
forall k v. Ord k => Map k v -> Diff k v -> Map k v
applyDiff Map Int V
x (Map Int V -> Map Int V -> Diff Int V
forall k v. (Ord k, Eq v) => Map k v -> Map k v -> Diff k v
diff Map Int V
x Map Int V
y) Map Int V -> Map Int V -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map Int V
y

-- | Applying an empty diff is the identity function.
prop_applyMempty :: Map K V -> Property
prop_applyMempty :: Map Int V -> Property
prop_applyMempty Map Int V
x = Map Int V -> Diff Int V -> Map Int V
forall k v. Ord k => Map k v -> Diff k v -> Map k v
applyDiff Map Int V
x Diff Int V
forall a. Monoid a => a
mempty Map Int V -> Map Int V -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map Int V
x

-- | Applying a sum of diffs is equivalent to applying each @'Diff'@
-- separately (in order).
prop_applySum :: Map K V -> [Diff K V] -> Property
prop_applySum :: Map Int V -> [Diff Int V] -> Property
prop_applySum Map Int V
x [Diff Int V]
ds = (Map Int V -> Diff Int V -> Map Int V)
-> Map Int V -> [Diff Int V] -> Map Int V
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Map Int V -> Diff Int V -> Map Int V
forall k v. Ord k => Map k v -> Diff k v -> Map k v
applyDiff Map Int V
x [Diff Int V]
ds Map Int V -> Map Int V -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map Int V -> Diff Int V -> Map Int V
forall k v. Ord k => Map k v -> Diff k v -> Map k v
applyDiff Map Int V
x ((Diff Int V -> Diff Int V) -> [Diff Int V] -> Diff Int V
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Diff Int V -> Diff Int V
forall a. a -> a
id [Diff Int V]
ds)

-- | Applying a @'Diff' d@ to a @'Map' m@ increases the size of @m@ by exactly
-- @numInserts d - numDeletes d@ if @d@ inserts only new keys and @d@ only
-- deletes existing keys.
--
-- Diffing two 'Map's that have disjoint keysets creates exactly a diff @d@ that
-- only inserts new keys and deletes existing keys.
prop_applyDiffNumInsertsDeletesExact :: Map K V -> Map K V -> Property
prop_applyDiffNumInsertsDeletesExact :: Map Int V -> Map Int V -> Property
prop_applyDiffNumInsertsDeletesExact Map Int V
m1 Map Int V
m2 =
    Map Int V -> Set Int
forall k a. Map k a -> Set k
Map.keysSet Map Int V
m1 Set Int -> Set Int -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.disjoint` Map Int V -> Set Int
forall k a. Map k a -> Set k
Map.keysSet Map Int V
m2 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
      Map Int V -> Int
forall k a. Map k a -> Int
Map.size (Map Int V -> Diff Int V -> Map Int V
forall k v. Ord k => Map k v -> Diff k v -> Map k v
applyDiff Map Int V
m1 Diff Int V
d) Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
        Map Int V -> Int
forall k a. Map k a -> Int
Map.size Map Int V
m1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Diff Int V -> Int
forall k v. Diff k v -> Int
numInserts Diff Int V
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Diff Int V -> Int
forall k v. Diff k v -> Int
numDeletes Diff Int V
d
  where
    d :: Diff Int V
d = Map Int V -> Map Int V -> Diff Int V
forall k v. (Ord k, Eq v) => Map k v -> Map k v -> Diff k v
diff Map Int V
m1 Map Int V
m2

-- | Applying a @'Diff' d@ to a @'Map' m@ may increase/decrease the size of @m@
-- up to bounds depending on the number of inserts and deletes in @d@.
--
-- * The size of @m@ may /decrease/ by up to the number of deletes in @d@. This
--   happens if @d@ does not insert any new keys.
-- * The size of @m@ may /increase/ by up to the number of inserts in @d@. This
--   if @d@ does not delete any existing keys.
prop_applyDiffNumInsertsDeletes :: Map K V -> Diff K V -> Property
prop_applyDiffNumInsertsDeletes :: Map Int V -> Diff Int V -> Property
prop_applyDiffNumInsertsDeletes Map Int V
m Diff Int V
d =
    Int
lb Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` Int
n' Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Int
n' Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` Int
ub
  where
    n :: Int
n        = Map Int V -> Int
forall k a. Map k a -> Int
Map.size Map Int V
m
    nInserts :: Int
nInserts = Diff Int V -> Int
forall k v. Diff k v -> Int
numInserts Diff Int V
d
    nDeletes :: Int
nDeletes = Diff Int V -> Int
forall k v. Diff k v -> Int
numDeletes Diff Int V
d
    n' :: Int
n'  = Map Int V -> Int
forall k a. Map k a -> Int
Map.size (Map Int V -> Diff Int V -> Map Int V
forall k v. Ord k => Map k v -> Diff k v -> Map k v
applyDiff Map Int V
m Diff Int V
d)
    lb :: Int
lb = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nDeletes
    ub :: Int
ub = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nInserts

{------------------------------------------------------------------------------
  Plain @'Arbitrary'@ instances
------------------------------------------------------------------------------}

deriving newtype instance (Ord k, Arbitrary k, Arbitrary v)
                       => Arbitrary (Diff k v)

instance Arbitrary v => Arbitrary (Delta v) where
  arbitrary :: Gen (Delta v)
arbitrary = [Gen (Delta v)] -> Gen (Delta v)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [
      v -> Delta v
forall v. v -> Delta v
Insert (v -> Delta v) -> Gen v -> Gen (Delta v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen v
forall a. Arbitrary a => Gen a
arbitrary
    , Delta v -> Gen (Delta v)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Delta v
forall v. Delta v
Delete
    ]
  shrink :: Delta v -> [Delta v]
shrink Delta v
de = case Delta v
de of
    Insert v
x -> v -> Delta v
forall v. v -> Delta v
Insert (v -> Delta v) -> [v] -> [Delta v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> [v]
forall a. Arbitrary a => a -> [a]
shrink v
x
    Delta v
Delete   -> []