{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.Ledger.Tables.DiffSeq (tests) where

import           Control.Monad (liftM)
import qualified Data.FingerTree.RootMeasured.Strict as RMFT
import           Data.Map.Diff.Strict (Delta (..), Diff)
import           Data.Map.Diff.Strict.Internal (DeltaHistory (..), Diff (..))
import           Data.Maybe.Strict (StrictMaybe (..))
import           Data.Sequence.NonEmpty (NESeq (..))
import           Data.Typeable
import           Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
import           Test.Consensus.Ledger.Tables.Diff (lawsTestOne)
import           Test.QuickCheck.Classes
import           Test.QuickCheck.Classes.Semigroup.Cancellative
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Orphans.Arbitrary ()

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Test.Consensus.Ledger.Tables.DiffSeq" [
    Proxy (RootMeasure Key Key)
-> [Proxy (RootMeasure Key Key) -> Laws] -> TestTree
forall a. Typeable a => Proxy a -> [Proxy a -> Laws] -> TestTree
lawsTestOne (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(RootMeasure Key Val)) [
        Proxy (RootMeasure Key Key) -> Laws
forall a.
(Semigroup a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Laws
semigroupLaws
      , Proxy (RootMeasure Key Key) -> Laws
forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
monoidLaws
      , Proxy (RootMeasure Key Key) -> Laws
forall a.
(Arbitrary a, Show a, Eq a, LeftReductive a) =>
Proxy a -> Laws
leftReductiveLaws
      , Proxy (RootMeasure Key Key) -> Laws
forall a.
(Arbitrary a, Show a, Eq a, RightReductive a) =>
Proxy a -> Laws
rightReductiveLaws
      , Proxy (RootMeasure Key Key) -> Laws
forall a.
(Arbitrary a, Show a, Eq a, LeftCancellative a) =>
Proxy a -> Laws
leftCancellativeLaws
      , Proxy (RootMeasure Key Key) -> Laws
forall a.
(Arbitrary a, Show a, Eq a, RightCancellative a) =>
Proxy a -> Laws
rightCancellativeLaws
      ]
  , Proxy (InternalMeasure Key Key)
-> [Proxy (InternalMeasure Key Key) -> Laws] -> TestTree
forall a. Typeable a => Proxy a -> [Proxy a -> Laws] -> TestTree
lawsTestOne (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(InternalMeasure Key Val)) [
        Proxy (InternalMeasure Key Key) -> Laws
forall a.
(Semigroup a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Laws
semigroupLaws
      , Proxy (InternalMeasure Key Key) -> Laws
forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
monoidLaws
      ]
  ]

type Key = Small Int
type Val = Small Int

{------------------------------------------------------------------------------
  Diffs
------------------------------------------------------------------------------}

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

instance (Arbitrary v) => Arbitrary (DeltaHistory v) where
  arbitrary :: Gen (DeltaHistory v)
arbitrary = NESeq (Delta v) -> DeltaHistory v
forall v. NESeq (Delta v) -> DeltaHistory v
DeltaHistory (NESeq (Delta v) -> DeltaHistory v)
-> Gen (NESeq (Delta v)) -> Gen (DeltaHistory v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (Delta v -> Seq (Delta v) -> NESeq (Delta v)
forall a. a -> Seq a -> NESeq a
(:<||) (Delta v -> Seq (Delta v) -> NESeq (Delta v))
-> Gen (Delta v) -> Gen (Seq (Delta v) -> NESeq (Delta v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Delta v)
forall a. Arbitrary a => Gen a
arbitrary Gen (Seq (Delta v) -> NESeq (Delta v))
-> Gen (Seq (Delta v)) -> Gen (NESeq (Delta v))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Seq (Delta v))
forall a. Arbitrary a => Gen a
arbitrary)

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
    ]

{-------------------------------------------------------------------------------
  DiffSeq
-------------------------------------------------------------------------------}

instance (RMFT.SuperMeasured vt vi a, Arbitrary a)
      => Arbitrary (RMFT.StrictFingerTree vt vi a) where
  arbitrary :: Gen (StrictFingerTree vt vi a)
arbitrary = [a] -> StrictFingerTree vt vi a
forall vr vi a.
SuperMeasured vr vi a =>
[a] -> StrictFingerTree vr vi a
RMFT.fromList ([a] -> StrictFingerTree vt vi a)
-> Gen [a] -> Gen (StrictFingerTree vt vi a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [a]
forall a. Arbitrary a => Gen a
arbitrary

instance (Ord k, Arbitrary k, Arbitrary v)
      => Arbitrary (RootMeasure k v) where
  arbitrary :: Gen (RootMeasure k v)
arbitrary = Length -> Diff k v -> Sum Int -> Sum Int -> RootMeasure k v
forall k v.
Length -> Diff k v -> Sum Int -> Sum Int -> RootMeasure k v
RootMeasure (Length -> Diff k v -> Sum Int -> Sum Int -> RootMeasure k v)
-> Gen Length
-> Gen (Diff k v -> Sum Int -> Sum Int -> RootMeasure k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Length
forall a. Arbitrary a => Gen a
arbitrary Gen (Diff k v -> Sum Int -> Sum Int -> RootMeasure k v)
-> Gen (Diff k v) -> Gen (Sum Int -> Sum Int -> RootMeasure k v)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Diff k v)
forall a. Arbitrary a => Gen a
arbitrary
                          Gen (Sum Int -> Sum Int -> RootMeasure k v)
-> Gen (Sum Int) -> Gen (Sum Int -> RootMeasure k v)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Sum Int)
forall a. Arbitrary a => Gen a
arbitrary Gen (Sum Int -> RootMeasure k v)
-> Gen (Sum Int) -> Gen (RootMeasure k v)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Sum Int)
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary (InternalMeasure k v) where
  arbitrary :: Gen (InternalMeasure k v)
arbitrary = Length
-> StrictMaybe SlotNoLB
-> StrictMaybe SlotNoUB
-> InternalMeasure k v
forall k v.
Length
-> StrictMaybe SlotNoLB
-> StrictMaybe SlotNoUB
-> InternalMeasure k v
InternalMeasure (Length
 -> StrictMaybe SlotNoLB
 -> StrictMaybe SlotNoUB
 -> InternalMeasure k v)
-> Gen Length
-> Gen
     (StrictMaybe SlotNoLB
      -> StrictMaybe SlotNoUB -> InternalMeasure k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Length
forall a. Arbitrary a => Gen a
arbitrary Gen
  (StrictMaybe SlotNoLB
   -> StrictMaybe SlotNoUB -> InternalMeasure k v)
-> Gen (StrictMaybe SlotNoLB)
-> Gen (StrictMaybe SlotNoUB -> InternalMeasure k v)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictMaybe SlotNoLB)
forall (f :: * -> *) a. (Arbitrary1 f, Arbitrary a) => Gen (f a)
arbitrary1 Gen (StrictMaybe SlotNoUB -> InternalMeasure k v)
-> Gen (StrictMaybe SlotNoUB) -> Gen (InternalMeasure k v)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictMaybe SlotNoUB)
forall (f :: * -> *) a. (Arbitrary1 f, Arbitrary a) => Gen (f a)
arbitrary1

deriving newtype instance Arbitrary DS.Length
deriving newtype instance Arbitrary DS.SlotNoUB
deriving newtype instance Arbitrary DS.SlotNoLB

instance Arbitrary1 StrictMaybe where
  liftArbitrary :: forall a. Gen a -> Gen (StrictMaybe a)
liftArbitrary Gen a
arb = [(Int, Gen (StrictMaybe a))] -> Gen (StrictMaybe a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, StrictMaybe a -> Gen (StrictMaybe a)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return StrictMaybe a
forall a. StrictMaybe a
SNothing), (Int
3, (a -> StrictMaybe a) -> Gen a -> Gen (StrictMaybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> StrictMaybe a
forall a. a -> StrictMaybe a
SJust Gen a
arb)]

  liftShrink :: forall a. (a -> [a]) -> StrictMaybe a -> [StrictMaybe a]
liftShrink a -> [a]
shr (SJust a
x) = StrictMaybe a
forall a. StrictMaybe a
SNothing StrictMaybe a -> [StrictMaybe a] -> [StrictMaybe a]
forall a. a -> [a] -> [a]
: [ a -> StrictMaybe a
forall a. a -> StrictMaybe a
SJust a
x' | a
x' <- a -> [a]
shr a
x ]
  liftShrink a -> [a]
_   StrictMaybe a
SNothing  = []