{-# 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
  , OTBlock
  , 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.Util.IndexedMemPack

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

type OTLedgerState k v = LedgerState (OTBlock k v)
type OTLedgerTables k v = LedgerTables (OTBlock 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, ZeroableMK mk) =>
  LedgerState (OTBlock k v) mk
emptyOTLedgerState :: forall k v (mk :: MapKind).
(Ord k, Eq 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) blk.
(ZeroableMK mk, LedgerTableConstraints blk) =>
LedgerTables blk 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 (OTBlock k v) ValuesMK
-> LedgerTables (OTBlock k v) ValuesMK
upgradeTables LedgerState (OTBlock k v) mk1
_ LedgerState (OTBlock k v) mk2
_ = LedgerTables (OTBlock k v) ValuesMK
-> LedgerTables (OTBlock k v) ValuesMK
forall a. a -> a
id

instance
  MemPack v =>
  IndexedMemPack LedgerState (OTBlock k v) v
  where
  indexedTypeName :: Proxy v -> LedgerState (OTBlock k v) EmptyMK -> String
indexedTypeName Proxy v
_ 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 s.
Buffer b =>
LedgerState (OTBlock k v) EmptyMK -> Unpack s b v
indexedUnpackM LedgerState (OTBlock k v) EmptyMK
_ = Unpack s b v
forall a b s. (MemPack a, Buffer b) => Unpack s b a
forall b s. Buffer b => Unpack s b v
unpackM

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

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

instance
  (Ord k, Eq 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 (OTBlock k v)) (TxOut (OTBlock k v))
forall blk (mk :: MapKind).
LedgerTables blk mk -> mk (TxIn blk) (TxOut blk)
getLedgerTables OTLedgerTables k v ValuesMK
otlsLedgerTables) OTLedgerTables k v EmptyMK
forall (mk :: MapKind) blk.
(ZeroableMK mk, LedgerTableConstraints blk) =>
LedgerTables blk 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 (OTBlock k v)) (TxOut (OTBlock k v))
-> OTLedgerTables k v ValuesMK
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables ValuesMK k v
ValuesMK (TxIn (OTBlock k v)) (TxOut (OTBlock k v))
otlsLedgerState)

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

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

instance
  (Ord k, Eq v, NoThunks k, NoThunks v) =>
  HasLedgerTables LedgerState (OTBlock k v)
  where
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (OTBlock k v) mk -> LedgerTables (OTBlock 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) =>
LedgerState (OTBlock k v) any
-> LedgerTables (OTBlock k v) mk -> LedgerState (OTBlock k v) mk
withLedgerTables LedgerState (OTBlock k v) any
st LedgerTables (OTBlock k v) mk
lt =
    LedgerState (OTBlock k v) any
st{otlsLedgerTables = lt}