{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | A simple ledger state that only holds ledger tables (and values).
--
-- This is useful when we only need a ledger state and ledger tables, but not
-- necessarily blocks with payloads (such as defined in @Test.Util.TestBlock@).
module Test.Util.LedgerStateOnlyTables
  ( OTLedgerState
  , OTLedgerTables
  , emptyOTLedgerState
  , pattern OTLedgerState
  ) where

import Data.MemPack
import GHC.Generics
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Ledger.Basics (LedgerState)
import Ouroboros.Consensus.Ledger.Tables
import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables)
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Util.IndexedMemPack

{-------------------------------------------------------------------------------
  Simple ledger state
-------------------------------------------------------------------------------}

type OTLedgerState k v = LedgerState (OTBlock k v)
type OTLedgerTables k v = LedgerTables (OTLedgerState k v)

-- | An empty type for blocks, which is only used to record the types @k@ and
-- @v@.
data OTBlock k v

data instance LedgerState (OTBlock k v) (mk :: MapKind) = OTLedgerState
  { forall k v (mk :: MapKind).
LedgerState (OTBlock k v) mk -> ValuesMK k v
otlsLedgerState :: ValuesMK k v
  , forall k v (mk :: MapKind).
LedgerState (OTBlock k v) mk -> OTLedgerTables k v mk
otlsLedgerTables :: OTLedgerTables k v mk
  }
  deriving (forall x.
 LedgerState (OTBlock k v) mk
 -> Rep (LedgerState (OTBlock k v) mk) x)
-> (forall x.
    Rep (LedgerState (OTBlock k v) mk) x
    -> LedgerState (OTBlock k v) mk)
-> Generic (LedgerState (OTBlock k v) mk)
forall x.
Rep (LedgerState (OTBlock k v) mk) x
-> LedgerState (OTBlock k v) mk
forall x.
LedgerState (OTBlock k v) mk
-> Rep (LedgerState (OTBlock k v) mk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k v (mk :: MapKind) x.
Rep (LedgerState (OTBlock k v) mk) x
-> LedgerState (OTBlock k v) mk
forall k v (mk :: MapKind) x.
LedgerState (OTBlock k v) mk
-> Rep (LedgerState (OTBlock k v) mk) x
$cfrom :: forall k v (mk :: MapKind) x.
LedgerState (OTBlock k v) mk
-> Rep (LedgerState (OTBlock k v) mk) x
from :: forall x.
LedgerState (OTBlock k v) mk
-> Rep (LedgerState (OTBlock k v) mk) x
$cto :: forall k v (mk :: MapKind) x.
Rep (LedgerState (OTBlock k v) mk) x
-> LedgerState (OTBlock k v) mk
to :: forall x.
Rep (LedgerState (OTBlock k v) mk) x
-> LedgerState (OTBlock k v) mk
Generic

deriving instance
  (Ord k, Eq v, Eq (mk k v)) =>
  Eq (OTLedgerState k v mk)
deriving stock instance
  (Show k, Show v, Show (mk k v)) =>
  Show (OTLedgerState k v mk)
deriving instance
  (NoThunks k, NoThunks v, NoThunks (mk k v)) =>
  NoThunks (OTLedgerState k v mk)

emptyOTLedgerState ::
  (Ord k, Eq v, MemPack k, MemPack v, ZeroableMK mk) =>
  LedgerState (OTBlock k v) mk
emptyOTLedgerState :: forall k v (mk :: MapKind).
(Ord k, Eq v, MemPack k, MemPack v, ZeroableMK mk) =>
LedgerState (OTBlock k v) mk
emptyOTLedgerState = ValuesMK k v
-> OTLedgerTables k v mk -> LedgerState (OTBlock k v) mk
forall k v (mk :: MapKind).
ValuesMK k v
-> OTLedgerTables k v mk -> LedgerState (OTBlock k v) mk
OTLedgerState ValuesMK k v
forall k v. (Ord k, Eq v) => ValuesMK k v
forall (mk :: MapKind) k v. (ZeroableMK mk, Ord k, Eq v) => mk k v
emptyMK OTLedgerTables k v mk
forall (mk :: MapKind) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables

instance CanUpgradeLedgerTables (LedgerState (OTBlock k v)) where
  upgradeTables :: forall (mk1 :: MapKind) (mk2 :: MapKind).
LedgerState (OTBlock k v) mk1
-> LedgerState (OTBlock k v) mk2
-> LedgerTables (LedgerState (OTBlock k v)) ValuesMK
-> LedgerTables (LedgerState (OTBlock k v)) ValuesMK
upgradeTables LedgerState (OTBlock k v) mk1
_ LedgerState (OTBlock k v) mk2
_ = LedgerTables (LedgerState (OTBlock k v)) ValuesMK
-> LedgerTables (LedgerState (OTBlock k v)) ValuesMK
forall a. a -> a
id

instance
  MemPack v =>
  IndexedMemPack (LedgerState (OTBlock k v) EmptyMK) v
  where
  indexedTypeName :: LedgerState (OTBlock k v) EmptyMK -> String
indexedTypeName LedgerState (OTBlock k v) EmptyMK
_ = forall a. MemPack a => String
typeName @v
  indexedPackedByteCount :: LedgerState (OTBlock k v) EmptyMK -> v -> Int
indexedPackedByteCount LedgerState (OTBlock k v) EmptyMK
_ = v -> Int
forall a. MemPack a => a -> Int
packedByteCount
  indexedPackM :: forall s. LedgerState (OTBlock k v) EmptyMK -> v -> Pack s ()
indexedPackM LedgerState (OTBlock k v) EmptyMK
_ = v -> Pack s ()
forall s. v -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM
  indexedUnpackM :: forall b.
Buffer b =>
LedgerState (OTBlock k v) EmptyMK -> Unpack b v
indexedUnpackM LedgerState (OTBlock k v) EmptyMK
_ = Unpack b v
forall b. Buffer b => Unpack b v
forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM

instance (Ord k, MemPack k, MemPack v) => SerializeTablesWithHint (LedgerState (OTBlock k v)) where
  encodeTablesWithHint :: SerializeTablesHint
  (LedgerTables (LedgerState (OTBlock k v)) ValuesMK)
-> LedgerTables (LedgerState (OTBlock k v)) ValuesMK -> Encoding
encodeTablesWithHint = SerializeTablesHint
  (LedgerTables (LedgerState (OTBlock k v)) ValuesMK)
-> LedgerTables (LedgerState (OTBlock k v)) ValuesMK -> Encoding
forall (l :: LedgerStateKind).
(MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> Encoding
defaultEncodeTablesWithHint
  decodeTablesWithHint :: forall s.
SerializeTablesHint
  (LedgerTables (LedgerState (OTBlock k v)) ValuesMK)
-> Decoder s (LedgerTables (LedgerState (OTBlock k v)) ValuesMK)
decodeTablesWithHint = SerializeTablesHint
  (LedgerTables (LedgerState (OTBlock k v)) ValuesMK)
-> Decoder s (LedgerTables (LedgerState (OTBlock k v)) ValuesMK)
forall (l :: LedgerStateKind) s.
(Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
defaultDecodeTablesWithHint

{-------------------------------------------------------------------------------
  Stowable
-------------------------------------------------------------------------------}

instance
  (Ord k, Eq v, MemPack k, MemPack v) =>
  CanStowLedgerTables (OTLedgerState k v)
  where
  stowLedgerTables :: OTLedgerState k v ValuesMK -> OTLedgerState k v EmptyMK
stowLedgerTables OTLedgerState{OTLedgerTables k v ValuesMK
otlsLedgerTables :: forall k v (mk :: MapKind).
LedgerState (OTBlock k v) mk -> OTLedgerTables k v mk
otlsLedgerTables :: OTLedgerTables k v ValuesMK
otlsLedgerTables} =
    ValuesMK k v
-> OTLedgerTables k v EmptyMK -> OTLedgerState k v EmptyMK
forall k v (mk :: MapKind).
ValuesMK k v
-> OTLedgerTables k v mk -> LedgerState (OTBlock k v) mk
OTLedgerState (OTLedgerTables k v ValuesMK
-> ValuesMK (TxIn (OTLedgerState k v)) (TxOut (OTLedgerState k v))
forall (l :: LedgerStateKind) (mk :: MapKind).
LedgerTables l mk -> mk (TxIn l) (TxOut l)
getLedgerTables OTLedgerTables k v ValuesMK
otlsLedgerTables) OTLedgerTables k v EmptyMK
forall (mk :: MapKind) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables

  unstowLedgerTables :: OTLedgerState k v EmptyMK -> OTLedgerState k v ValuesMK
unstowLedgerTables OTLedgerState{ValuesMK k v
otlsLedgerState :: forall k v (mk :: MapKind).
LedgerState (OTBlock k v) mk -> ValuesMK k v
otlsLedgerState :: ValuesMK k v
otlsLedgerState} =
    ValuesMK k v
-> OTLedgerTables k v ValuesMK -> OTLedgerState k v ValuesMK
forall k v (mk :: MapKind).
ValuesMK k v
-> OTLedgerTables k v mk -> LedgerState (OTBlock k v) mk
OTLedgerState
      ValuesMK k v
forall k v. (Ord k, Eq v) => ValuesMK k v
forall (mk :: MapKind) k v. (ZeroableMK mk, Ord k, Eq v) => mk k v
emptyMK
      (ValuesMK (TxIn (OTLedgerState k v)) (TxOut (OTLedgerState k v))
-> OTLedgerTables k v ValuesMK
forall (l :: LedgerStateKind) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables ValuesMK k v
ValuesMK (TxIn (OTLedgerState k v)) (TxOut (OTLedgerState k v))
otlsLedgerState)

{-------------------------------------------------------------------------------
  Simple ledger tables
-------------------------------------------------------------------------------}

type instance TxIn (OTLedgerState k v) = k
type instance TxOut (OTLedgerState k v) = v

instance
  (Ord k, Eq v, Show k, Show v, MemPack k, MemPack v, NoThunks k, NoThunks v) =>
  HasLedgerTables (OTLedgerState k v)
  where
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
OTLedgerState k v mk -> LedgerTables (OTLedgerState k v) mk
projectLedgerTables OTLedgerState{OTLedgerTables k v mk
otlsLedgerTables :: forall k v (mk :: MapKind).
LedgerState (OTBlock k v) mk -> OTLedgerTables k v mk
otlsLedgerTables :: OTLedgerTables k v mk
otlsLedgerTables} =
    OTLedgerTables k v mk
otlsLedgerTables

  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
OTLedgerState k v any
-> LedgerTables (OTLedgerState k v) mk -> OTLedgerState k v mk
withLedgerTables OTLedgerState k v any
st LedgerTables (OTLedgerState k v) mk
lt =
    OTLedgerState k v any
st{otlsLedgerTables = lt}