{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{- HLINT ignore "Use camelCase" -}

module Test.Ouroboros.Storage.LedgerDB.V1.BackingStore
  ( labelledExamples
  , tests
  ) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Slotting.Slot
import Control.Concurrent.Class.MonadMVar.Strict
import Control.Concurrent.Class.MonadSTM.Strict.TMVar
import Control.Monad.Class.MonadThrow (Handler (..), catches)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (runReaderT)
import qualified Data.Map.Strict as Map
import Data.MemPack
import qualified Data.SOP.Dict as Dict
import qualified Data.Set as Set
import Data.Typeable
import Ouroboros.Consensus.Ledger.Tables
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
import Ouroboros.Consensus.Ledger.Tables.Utils
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as BS
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as BS
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as InMemory
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike hiding
  ( MonadMask (..)
  , newMVar
  , newTVarIO
  , readMVar
  )
import qualified System.Directory as Dir
import System.FS.API hiding (Handle)
import System.FS.IO (ioHasFS)
import qualified System.FS.Sim.MockFS as MockFS
import System.FS.Sim.STM
import qualified System.FilePath as FilePath
import System.IO.Temp (createTempDirectory)
import Test.Ouroboros.Storage.LedgerDB.V1.BackingStore.Lockstep
import qualified Test.Ouroboros.Storage.LedgerDB.V1.BackingStore.Mock as Mock
import Test.Ouroboros.Storage.LedgerDB.V1.LMDB (testLMDBLimits)
import Test.QuickCheck (Arbitrary (..), Property)
import qualified Test.QuickCheck as QC
import Test.QuickCheck.StateModel as StateModel
import Test.QuickCheck.StateModel.Lockstep as Lockstep
import Test.QuickCheck.StateModel.Lockstep.Run as Lockstep
import Test.Tasty
import Test.Tasty.QuickCheck (QuickCheckTests (..), testProperty)
import Test.Util.LedgerStateOnlyTables
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Orphans.IOLike ()
import Test.Util.Orphans.ToExpr ()

{-------------------------------------------------------------------------------
  Main test tree
-------------------------------------------------------------------------------}

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"BackingStore"
    [ (QuickCheckTests -> QuickCheckTests) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Int -> QuickCheckTests -> QuickCheckTests
scaleQuickCheckTests Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> (Actions (Lockstep T) -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"InMemory IO SimHasFS" ((Actions (Lockstep T) -> Property) -> TestTree)
-> (Actions (Lockstep T) -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$
          IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property
testWithIO (IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property)
-> IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property
forall a b. (a -> b) -> a -> b
$
            Complete BackingStoreArgs IO
-> IO (SomeHasFS IO) -> IO () -> IO (BSEnv IO K V D)
forall (m :: * -> *).
IOLike m =>
Complete BackingStoreArgs m
-> m (SomeHasFS m) -> m () -> m (BSEnv m K V D)
setupBSEnv Complete BackingStoreArgs IO
forall (f :: * -> *) (m :: * -> *). BackingStoreArgs f m
BS.InMemoryBackingStoreArgs IO (SomeHasFS IO)
forall (m :: * -> *). IOLike m => m (SomeHasFS m)
setupSimHasFS (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    , (QuickCheckTests -> QuickCheckTests) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Int -> QuickCheckTests -> QuickCheckTests
scaleQuickCheckTests Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> (Actions (Lockstep T) -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"InMemory IO IOHasFS" ((Actions (Lockstep T) -> Property) -> TestTree)
-> (Actions (Lockstep T) -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$
          IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property
testWithIO (IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property)
-> IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property
forall a b. (a -> b) -> a -> b
$ do
            (fp, cleanup) <- IO (TestName, IO ())
forall (m :: * -> *). MonadIO m => m (TestName, m ())
setupTempDir
            setupBSEnv BS.InMemoryBackingStoreArgs (setupIOHasFS fp) cleanup
    , (QuickCheckTests -> QuickCheckTests) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Int -> QuickCheckTests -> QuickCheckTests
scaleQuickCheckTests Int
2) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> (Actions (Lockstep T) -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"LMDB IO IOHasFS" ((Actions (Lockstep T) -> Property) -> TestTree)
-> (Actions (Lockstep T) -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$
          IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property
testWithIO (IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property)
-> IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property
forall a b. (a -> b) -> a -> b
$ do
            (fp, cleanup) <- IO (TestName, IO ())
forall (m :: * -> *). MonadIO m => m (TestName, m ())
setupTempDir
            lmdbTmpDir <- (FilePath.</> "BS_LMDB") <$> Dir.getTemporaryDirectory
            setupBSEnv
              (BS.LMDBBackingStoreArgs lmdbTmpDir (testLMDBLimits maxOpenValueHandles) Dict.Dict)
              (setupIOHasFS fp)
              (cleanup >> Dir.removeDirectoryRecursive lmdbTmpDir)
    ]

scaleQuickCheckTests :: Int -> QuickCheckTests -> QuickCheckTests
scaleQuickCheckTests :: Int -> QuickCheckTests -> QuickCheckTests
scaleQuickCheckTests Int
c (QuickCheckTests Int
n) = Int -> QuickCheckTests
QuickCheckTests (Int -> QuickCheckTests) -> Int -> QuickCheckTests
forall a b. (a -> b) -> a -> b
$ Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n

testWithIO ::
  IO (BSEnv IO K V D) ->
  Actions (Lockstep T) ->
  Property
testWithIO :: IO (BSEnv IO K V D) -> Actions (Lockstep T) -> Property
testWithIO IO (BSEnv IO K V D)
mkBSEnv = Proxy T
-> IO (BSEnv IO K V D)
-> (BSEnv IO K V D -> IO ())
-> (ReaderT (RealEnv IO K V D) IO Property
    -> BSEnv IO K V D -> IO Property)
-> Actions (Lockstep T)
-> Property
forall state (m :: * -> *) e st.
(RunLockstep state m, e ~ Error (Lockstep state),
 forall a. IsPerformResult e a) =>
Proxy state
-> IO st
-> (st -> IO ())
-> (m Property -> st -> IO Property)
-> Actions (Lockstep state)
-> Property
runActionsBracket Proxy T
pT IO (BSEnv IO K V D)
mkBSEnv BSEnv IO K V D -> IO ()
forall (m :: * -> *) ks vs d. BSEnv m ks vs d -> m ()
bsCleanup ReaderT (RealEnv IO K V D) IO Property
-> BSEnv IO K V D -> IO Property
forall (m :: * -> *) ks vs d a.
RealMonad m ks vs d a -> BSEnv m ks vs d -> m a
runner

runner ::
  RealMonad m ks vs d a ->
  BSEnv m ks vs d ->
  m a
runner :: forall (m :: * -> *) ks vs d a.
RealMonad m ks vs d a -> BSEnv m ks vs d -> m a
runner RealMonad m ks vs d a
c BSEnv m ks vs d
r = RealMonad m ks vs d a -> RealEnv m ks vs d -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RealMonad m ks vs d a
c (RealEnv m ks vs d -> m a) -> RealEnv m ks vs d -> m a
forall a b. (a -> b) -> a -> b
$ BSEnv m ks vs d -> RealEnv m ks vs d
forall (m :: * -> *) ks vs d. BSEnv m ks vs d -> RealEnv m ks vs d
bsRealEnv BSEnv m ks vs d
r

-- | Generate minimal examples for each label.
labelledExamples :: IO ()
labelledExamples :: IO ()
labelledExamples = (Actions (Lockstep T) -> Property) -> IO ()
forall prop. Testable prop => prop -> IO ()
QC.labelledExamples ((Actions (Lockstep T) -> Property) -> IO ())
-> (Actions (Lockstep T) -> Property) -> IO ()
forall a b. (a -> b) -> a -> b
$ Proxy T -> Actions (Lockstep T) -> Property
forall state.
InLockstep state =>
Proxy state -> Actions (Lockstep state) -> Property
tagActions Proxy T
pT

{-------------------------------------------------------------------------------
  Resources
-------------------------------------------------------------------------------}

data BSEnv m ks vs d = BSEnv
  { forall (m :: * -> *) ks vs d. BSEnv m ks vs d -> RealEnv m ks vs d
bsRealEnv :: RealEnv m ks vs d
  , forall (m :: * -> *) ks vs d. BSEnv m ks vs d -> m ()
bsCleanup :: m ()
  }

-- | Set up a simulated @'HasFS'@.
setupSimHasFS :: IOLike m => m (SomeHasFS m)
setupSimHasFS :: forall (m :: * -> *). IOLike m => m (SomeHasFS m)
setupSimHasFS = HasFS m HandleMock -> SomeHasFS m
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS m HandleMock -> SomeHasFS m)
-> (StrictTMVar m MockFS -> HasFS m HandleMock)
-> StrictTMVar m MockFS
-> SomeHasFS m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTMVar m MockFS -> HasFS m HandleMock
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m) =>
StrictTMVar m MockFS -> HasFS m HandleMock
simHasFS (StrictTMVar m MockFS -> SomeHasFS m)
-> m (StrictTMVar m MockFS) -> m (SomeHasFS m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockFS -> m (StrictTMVar m MockFS)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTMVar m a)
newTMVarIO MockFS
MockFS.empty

-- | Set up a @'HasFS'@ for @'IO'@.
setupIOHasFS :: (PrimState m ~ PrimState IO, MonadIO m) => FilePath -> m (SomeHasFS m)
setupIOHasFS :: forall (m :: * -> *).
(PrimState m ~ PrimState IO, MonadIO m) =>
TestName -> m (SomeHasFS m)
setupIOHasFS = SomeHasFS m -> m (SomeHasFS m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeHasFS m -> m (SomeHasFS m))
-> (TestName -> SomeHasFS m) -> TestName -> m (SomeHasFS m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasFS m HandleIO -> SomeHasFS m
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS m HandleIO -> SomeHasFS m)
-> (TestName -> HasFS m HandleIO) -> TestName -> SomeHasFS m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> HasFS m HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS m HandleIO)
-> (TestName -> MountPoint) -> TestName -> HasFS m HandleIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> MountPoint
MountPoint

-- | In case we are running tests in @'IO'@, we must do some temporary directory
-- management.
setupTempDir :: MonadIO m => m (FilePath, m ())
setupTempDir :: forall (m :: * -> *). MonadIO m => m (TestName, m ())
setupTempDir = do
  sysTmpDir <- IO TestName -> m TestName
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TestName
Dir.getTemporaryDirectory
  qsmTmpDir <- liftIO $ createTempDirectory sysTmpDir "BS_QSM"
  pure (qsmTmpDir, liftIO $ Dir.removeDirectoryRecursive qsmTmpDir)

setupBSEnv ::
  IOLike m =>
  Complete BS.BackingStoreArgs m ->
  m (SomeHasFS m) ->
  m () ->
  m (BSEnv m K V D)
setupBSEnv :: forall (m :: * -> *).
IOLike m =>
Complete BackingStoreArgs m
-> m (SomeHasFS m) -> m () -> m (BSEnv m K V D)
setupBSEnv Complete BackingStoreArgs m
mkBsArgs m (SomeHasFS m)
mkShfs m ()
cleanup = do
  shfs@(SomeHasFS hfs) <- m (SomeHasFS m)
mkShfs

  createDirectory hfs (mkFsPath ["copies"])

  let bsi = Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> BackingStoreInitialiser
     m (LedgerState (OTBlock (Fixed Word) (Fixed Word)))
forall (m :: * -> *) (l :: MapKind -> *).
(IOLike m, HasLedgerTables l, HasCallStack,
 CanUpgradeLedgerTables l, MemPackIdx l EmptyMK ~ l EmptyMK,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> BackingStoreInitialiser m l
BS.newBackingStoreInitialiser Tracer m FlavorImplSpecificTrace
forall a. Monoid a => a
mempty Complete BackingStoreArgs m
mkBsArgs (SomeHasFS m -> SnapshotsFS m
forall (m :: * -> *). SomeHasFS m -> SnapshotsFS m
BS.SnapshotsFS SomeHasFS m
shfs)

  bsVar <- newMVar =<< bsi (BS.InitFromValues Origin emptyOTLedgerState emptyLedgerTables)

  let
    bsCleanup = do
      bs <- StrictMVar
  m
  (LedgerBackingStore
     m (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
-> m (LedgerBackingStore
        m (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
readMVar StrictMVar
  m
  (LedgerBackingStore
     m (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
bsVar
      catches (BS.bsClose bs) closeHandlers
      cleanup

  pure
    BSEnv
      { bsRealEnv =
          RealEnv
            { reBackingStoreInit = bsi
            , reBackingStore = bsVar
            }
      , bsCleanup
      }

-- | A backing store will throw an error on close if it has already been closed,
-- which we ignore if we are performing a close as part of resource cleanup.
closeHandlers :: IOLike m => [Handler m ()]
closeHandlers :: forall (m :: * -> *). IOLike m => [Handler m ()]
closeHandlers =
  [ (InMemoryBackingStoreExn -> m ()) -> Handler m ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((InMemoryBackingStoreExn -> m ()) -> Handler m ())
-> (InMemoryBackingStoreExn -> m ()) -> Handler m ()
forall a b. (a -> b) -> a -> b
$ \case
      InMemoryBackingStoreExn
InMemory.InMemoryBackingStoreClosedExn -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      InMemoryBackingStoreExn
e -> InMemoryBackingStoreExn -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO InMemoryBackingStoreExn
e
  , (LMDBErr -> m ()) -> Handler m ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((LMDBErr -> m ()) -> Handler m ())
-> (LMDBErr -> m ()) -> Handler m ()
forall a b. (a -> b) -> a -> b
$ \case
      LMDBErr
LMDB.LMDBErrClosed -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LMDBErr
e -> LMDBErr -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO LMDBErr
e
  ]

{-------------------------------------------------------------------------------
  Types under test
-------------------------------------------------------------------------------}

type T = BackingStoreState K V D

pT :: Proxy T
pT :: Proxy T
pT = Proxy T
forall {k} (t :: k). Proxy t
Proxy

type K = LedgerTables (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) KeysMK
type V = LedgerTables (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) ValuesMK
type D = LedgerTables (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) DiffMK

{-------------------------------------------------------------------------------
  @'HasOps'@ instances
-------------------------------------------------------------------------------}

instance Mock.EmptyValues V where
  emptyValues :: V
emptyValues = V
forall (mk :: MapKind) (l :: MapKind -> *).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables

instance Mock.ApplyDiff V D where
  applyDiff :: V -> D -> V
applyDiff = V -> D -> V
forall (l :: MapKind -> *) (l'' :: MapKind -> *)
       (l' :: MapKind -> *).
(SameUtxoTypes l l'', SameUtxoTypes l' l'', HasLedgerTables l,
 HasLedgerTables l', HasLedgerTables l'') =>
l ValuesMK -> l' DiffMK -> LedgerTables l'' ValuesMK
applyDiffs'

instance Mock.LookupKeysRange K V where
  lookupKeysRange :: Maybe K -> Int -> V -> V
lookupKeysRange = \Maybe K
prev Int
n V
vs ->
    case Maybe K
prev of
      Maybe K
Nothing ->
        (forall k v.
 LedgerTableConstraints'
   (LedgerState (OTBlock (Fixed Word) (Fixed Word))) k v =>
 ValuesMK k v -> ValuesMK k v)
-> V -> V
forall (l :: MapKind -> *) (mk1 :: MapKind) (mk2 :: MapKind).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (Int -> ValuesMK k v -> ValuesMK k v
forall k v. Int -> ValuesMK k v -> ValuesMK k v
rangeRead Int
n) V
vs
      Just K
ks ->
        (forall k v.
 LedgerTableConstraints'
   (LedgerState (OTBlock (Fixed Word) (Fixed Word))) k v =>
 KeysMK k v -> ValuesMK k v -> ValuesMK k v)
-> K -> V -> V
forall (l :: MapKind -> *) (mk1 :: MapKind) (mk2 :: MapKind)
       (mk3 :: MapKind).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 (Int -> KeysMK k v -> ValuesMK k v -> ValuesMK k v
forall k v.
Ord k =>
Int -> KeysMK k v -> ValuesMK k v -> ValuesMK k v
rangeRead' Int
n) K
ks V
vs
   where
    rangeRead :: Int -> ValuesMK k v -> ValuesMK k v
    rangeRead :: forall k v. Int -> ValuesMK k v -> ValuesMK k v
rangeRead Int
n (ValuesMK Map k v
vs) =
      Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> Map k v -> ValuesMK k v
forall a b. (a -> b) -> a -> b
$ Int -> Map k v -> Map k v
forall k a. Int -> Map k a -> Map k a
Map.take Int
n Map k v
vs

    rangeRead' ::
      Ord k =>
      Int ->
      KeysMK k v ->
      ValuesMK k v ->
      ValuesMK k v
    rangeRead' :: forall k v.
Ord k =>
Int -> KeysMK k v -> ValuesMK k v -> ValuesMK k v
rangeRead' Int
n KeysMK k v
ksmk ValuesMK k v
vsmk =
      case Set k -> Maybe k
forall a. Set a -> Maybe a
Set.lookupMax Set k
ks of
        Maybe k
Nothing -> Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK Map k v
forall k a. Map k a
Map.empty
        Just k
k ->
          Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> Map k v -> ValuesMK k v
forall a b. (a -> b) -> a -> b
$
            Int -> Map k v -> Map k v
forall k a. Int -> Map k a -> Map k a
Map.take Int
n (Map k v -> Map k v) -> Map k v -> Map k v
forall a b. (a -> b) -> a -> b
$
              (Map k v, Map k v) -> Map k v
forall a b. (a, b) -> b
snd ((Map k v, Map k v) -> Map k v) -> (Map k v, Map k v) -> Map k v
forall a b. (a -> b) -> a -> b
$
                k -> Map k v -> (Map k v, Map k v)
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split k
k Map k v
vs
     where
      KeysMK Set k
ks = KeysMK k v
ksmk
      ValuesMK Map k v
vs = ValuesMK k v
vsmk

instance Mock.LookupKeys K V where
  lookupKeys :: K -> V -> V
lookupKeys = (forall k v.
 LedgerTableConstraints'
   (LedgerState (OTBlock (Fixed Word) (Fixed Word))) k v =>
 KeysMK k v -> ValuesMK k v -> ValuesMK k v)
-> K -> V -> V
forall (l :: MapKind -> *) (mk1 :: MapKind) (mk2 :: MapKind)
       (mk3 :: MapKind).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 KeysMK k v -> ValuesMK k v -> ValuesMK k v
forall k v. Ord k => KeysMK k v -> ValuesMK k v -> ValuesMK k v
forall k v.
LedgerTableConstraints'
  (LedgerState (OTBlock (Fixed Word) (Fixed Word))) k v =>
KeysMK k v -> ValuesMK k v -> ValuesMK k v
readKeys
   where
    readKeys ::
      Ord k =>
      KeysMK k v ->
      ValuesMK k v ->
      ValuesMK k v
    readKeys :: forall k v. Ord k => KeysMK k v -> ValuesMK k v -> ValuesMK k v
readKeys (KeysMK Set k
ks) (ValuesMK Map k v
vs) =
      Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> Map k v -> ValuesMK k v
forall a b. (a -> b) -> a -> b
$ Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map k v
vs Set k
ks

instance Mock.ValuesLength V where
  valuesLength :: V -> Int
valuesLength (LedgerTables (ValuesMK Map
  (TxIn (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
  (TxOut (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
m)) =
    Map (Fixed Word) (Fixed Word) -> Int
forall k a. Map k a -> Int
Map.size Map (Fixed Word) (Fixed Word)
Map
  (TxIn (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
  (TxOut (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
m

instance Mock.MakeDiff V D where
  diff :: V -> V -> D
diff V
t1 V
t2 = LedgerTables
  (LedgerState (OTBlock (Fixed Word) (Fixed Word))) TrackingMK
-> D
forall (l :: MapKind -> *).
(HasLedgerTables l, LedgerTableConstraints l) =>
l TrackingMK -> l DiffMK
trackingToDiffs (LedgerTables
   (LedgerState (OTBlock (Fixed Word) (Fixed Word))) TrackingMK
 -> D)
-> LedgerTables
     (LedgerState (OTBlock (Fixed Word) (Fixed Word))) TrackingMK
-> D
forall a b. (a -> b) -> a -> b
$ V
-> V
-> LedgerTables
     (LedgerState (OTBlock (Fixed Word) (Fixed Word))) TrackingMK
forall (l :: MapKind -> *) (l' :: MapKind -> *).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' ValuesMK -> l' TrackingMK
calculateDifference V
t1 V
t2

instance Mock.DiffSize D where
  diffSize :: D -> Int
diffSize (LedgerTables (DiffMK (Diff.Diff Map
  (TxIn (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
  (Delta (TxOut (LedgerState (OTBlock (Fixed Word) (Fixed Word)))))
m))) = Map (Fixed Word) (Delta (Fixed Word)) -> Int
forall k a. Map k a -> Int
Map.size Map (Fixed Word) (Delta (Fixed Word))
Map
  (TxIn (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
  (Delta (TxOut (LedgerState (OTBlock (Fixed Word) (Fixed Word)))))
m

instance Mock.KeysSize K where
  keysSize :: K -> Int
keysSize (LedgerTables (KeysMK Set (TxIn (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
s)) = Set (Fixed Word) -> Int
forall a. Set a -> Int
Set.size Set (Fixed Word)
Set (TxIn (LedgerState (OTBlock (Fixed Word) (Fixed Word))))
s

instance Mock.MakeInitHint V where
  makeInitHint :: Proxy V -> InitHint V
makeInitHint Proxy V
_ = LedgerState (OTBlock (Fixed Word) (Fixed Word)) EmptyMK
InitHint V
forall k v (mk :: MapKind).
(Ord k, Eq v, MemPack k, MemPack v, ZeroableMK mk) =>
LedgerState (OTBlock k v) mk
emptyOTLedgerState

instance Mock.MakeWriteHint D where
  makeWriteHint :: Proxy D -> WriteHint D
makeWriteHint Proxy D
_ = (LedgerState (OTBlock (Fixed Word) (Fixed Word)) EmptyMK
forall k v (mk :: MapKind).
(Ord k, Eq v, MemPack k, MemPack v, ZeroableMK mk) =>
LedgerState (OTBlock k v) mk
emptyOTLedgerState, LedgerState (OTBlock (Fixed Word) (Fixed Word)) EmptyMK
forall k v (mk :: MapKind).
(Ord k, Eq v, MemPack k, MemPack v, ZeroableMK mk) =>
LedgerState (OTBlock k v) mk
emptyOTLedgerState)

instance Mock.MakeReadHint V where
  makeReadHint :: Proxy V -> ReadHint V
makeReadHint Proxy V
_ = LedgerState (OTBlock (Fixed Word) (Fixed Word)) EmptyMK
ReadHint V
forall k v (mk :: MapKind).
(Ord k, Eq v, MemPack k, MemPack v, ZeroableMK mk) =>
LedgerState (OTBlock k v) mk
emptyOTLedgerState

instance Mock.MakeSerializeTablesHint V where
  makeSerializeTablesHint :: Proxy V -> SerializeTablesHint V
makeSerializeTablesHint Proxy V
_ = SerializeTablesHint V
LedgerState (OTBlock (Fixed Word) (Fixed Word)) EmptyMK
forall k v (mk :: MapKind).
(Ord k, Eq v, MemPack k, MemPack v, ZeroableMK mk) =>
LedgerState (OTBlock k v) mk
emptyOTLedgerState

instance Mock.HasOps K V D

{-------------------------------------------------------------------------------
  Orphan Arbitrary instances
-------------------------------------------------------------------------------}

deriving newtype instance
  QC.Arbitrary (mk k v) =>
  QC.Arbitrary (OTLedgerTables k v mk)

instance
  (Ord k, QC.Arbitrary k) =>
  QC.Arbitrary (KeysMK k v)
  where
  arbitrary :: Gen (KeysMK k v)
arbitrary = Set k -> KeysMK k v
forall k v. Set k -> KeysMK k v
KeysMK (Set k -> KeysMK k v) -> Gen (Set k) -> Gen (KeysMK k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Set k)
forall a. Arbitrary a => Gen a
QC.arbitrary
  shrink :: KeysMK k v -> [KeysMK k v]
shrink (KeysMK Set k
ks) = Set k -> KeysMK k v
forall k v. Set k -> KeysMK k v
KeysMK (Set k -> KeysMK k v) -> [Set k] -> [KeysMK k v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set k -> [Set k]
forall a. Arbitrary a => a -> [a]
QC.shrink Set k
ks

instance
  (Ord k, QC.Arbitrary k, QC.Arbitrary v) =>
  QC.Arbitrary (DiffMK k v)
  where
  arbitrary :: Gen (DiffMK k v)
arbitrary = Diff k v -> DiffMK k v
forall k v. Diff k v -> DiffMK k v
DiffMK (Diff k v -> DiffMK k v) -> Gen (Diff k v) -> Gen (DiffMK k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Diff k v)
forall a. Arbitrary a => Gen a
QC.arbitrary
  shrink :: DiffMK k v -> [DiffMK k v]
shrink (DiffMK Diff k v
d) = Diff k v -> DiffMK k v
forall k v. Diff k v -> DiffMK k v
DiffMK (Diff k v -> DiffMK k v) -> [Diff k v] -> [DiffMK k v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Diff k v -> [Diff k v]
forall a. Arbitrary a => a -> [a]
QC.shrink Diff k v
d

instance
  (Ord k, QC.Arbitrary k, QC.Arbitrary v) =>
  QC.Arbitrary (ValuesMK k v)
  where
  arbitrary :: Gen (ValuesMK k v)
arbitrary = Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> Gen (Map k v) -> Gen (ValuesMK k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Map k v)
forall a. Arbitrary a => Gen a
QC.arbitrary
  shrink :: ValuesMK k v -> [ValuesMK k v]
shrink (ValuesMK Map k v
vs) = Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> [Map k v] -> [ValuesMK k v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map k v -> [Map k v]
forall a. Arbitrary a => a -> [a]
QC.shrink Map k v
vs

deriving newtype instance
  (Ord k, QC.Arbitrary k, QC.Arbitrary v) =>
  QC.Arbitrary (Diff.Diff k v)
instance QC.Arbitrary v => QC.Arbitrary (Diff.Delta v) where
  arbitrary :: Gen (Delta v)
arbitrary =
    [Gen (Delta v)] -> Gen (Delta v)
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
      [ v -> Delta v
forall v. v -> Delta v
Diff.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
QC.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
Diff.Delete
      ]

instance QC.Arbitrary ks => QC.Arbitrary (BS.RangeQuery ks) where
  arbitrary :: Gen (RangeQuery ks)
arbitrary = Maybe ks -> Int -> RangeQuery ks
forall keys. Maybe keys -> Int -> RangeQuery keys
BS.RangeQuery (Maybe ks -> Int -> RangeQuery ks)
-> Gen (Maybe ks) -> Gen (Int -> RangeQuery ks)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Maybe ks)
forall a. Arbitrary a => Gen a
QC.arbitrary Gen (Int -> RangeQuery ks) -> Gen Int -> Gen (RangeQuery ks)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Int
forall a. Arbitrary a => Gen a
QC.arbitrary
  shrink :: RangeQuery ks -> [RangeQuery ks]
shrink (BS.RangeQuery Maybe ks
x Int
y) = Maybe ks -> Int -> RangeQuery ks
forall keys. Maybe keys -> Int -> RangeQuery keys
BS.RangeQuery (Maybe ks -> Int -> RangeQuery ks)
-> [Maybe ks] -> [Int -> RangeQuery ks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ks -> [Maybe ks]
forall a. Arbitrary a => a -> [a]
QC.shrink Maybe ks
x [Int -> RangeQuery ks] -> [Int] -> [RangeQuery ks]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> [Int]
forall a. Arbitrary a => a -> [a]
QC.shrink Int
y

instance NoThunks a => NoThunks (QC.Fixed a) where
  wNoThunks :: [TestName] -> Fixed a -> IO (Maybe ThunkInfo)
wNoThunks [TestName]
ctxt = [TestName] -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => [TestName] -> a -> IO (Maybe ThunkInfo)
wNoThunks [TestName]
ctxt (a -> IO (Maybe ThunkInfo))
-> (Fixed a -> a) -> Fixed a -> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixed a -> a
forall a. Fixed a -> a
QC.getFixed
  showTypeOf :: Proxy (Fixed a) -> TestName
showTypeOf Proxy (Fixed a)
_ = TestName
"Fixed " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Proxy a -> TestName
forall a. NoThunks a => Proxy a -> TestName
showTypeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

deriving newtype instance MemPack a => MemPack (QC.Fixed a)
deriving newtype instance FromCBOR a => FromCBOR (QC.Fixed a)
deriving newtype instance ToCBOR a => ToCBOR (QC.Fixed a)