{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

module Cardano.Api.LedgerEvent
  ( LedgerEvent (..),
    MIRDistributionDetails (..),
    PoolReapDetails (..),
    toLedgerEvent,
  )
where

import           Cardano.Api.Address (StakeCredential, fromShelleyStakeCredential)
import           Cardano.Api.Block (EpochNo)
import           Cardano.Api.Certificate (Certificate)
import           Cardano.Api.KeysShelley (Hash (StakePoolKeyHash), StakePoolKey)
import           Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace)
import qualified Cardano.Ledger.Coin as Ledger
import qualified Cardano.Ledger.Core as Ledger.Core
import qualified Cardano.Ledger.Credential as Ledger
import           Cardano.Ledger.Crypto (StandardCrypto)
import           Cardano.Ledger.Era (Crypto)
import qualified Cardano.Ledger.Keys as Ledger
import           Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards))
import           Cardano.Ledger.Shelley.Rewards
import           Cardano.Ledger.Shelley.Rules.Epoch (EpochEvent (PoolReapEvent))
import           Cardano.Ledger.Shelley.Rules.Mir (MirEvent (..))
import           Cardano.Ledger.Shelley.Rules.NewEpoch
                   (NewEpochEvent (DeltaRewardEvent, EpochEvent, MirEvent, TotalRewardEvent))
import           Cardano.Ledger.Shelley.Rules.PoolReap (PoolreapEvent (RetiredPools))
import           Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (RupdEvent))
import           Cardano.Ledger.Shelley.Rules.Tick (TickEvent (NewEpochEvent))
import           Control.State.Transition (Event)
import           Data.Function (($), (.))
import           Data.Functor (fmap)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe (Just, Nothing))
import           Data.SOP.Strict
import           Data.Set (Set)
import           Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
import           Ouroboros.Consensus.Cardano.Block (HardForkBlock)
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent)
import           Ouroboros.Consensus.Ledger.Abstract (LedgerState)
import           Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent)
import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock,
                   ShelleyLedgerEvent (ShelleyLedgerEventTICK))
import           Ouroboros.Consensus.TypeFamilyWrappers

data LedgerEvent
  = -- | The given pool is being registered for the first time on chain.
    PoolRegistration Certificate
  | -- | The given pool already exists and is being re-registered.
    PoolReRegistration Certificate
  | -- | Incremental rewards are being computed.
    IncrementalRewardsDistribution EpochNo (Map StakeCredential (Set (Reward StandardCrypto)))
  | -- | Reward distribution has completed.
    RewardsDistribution EpochNo (Map StakeCredential (Set (Reward StandardCrypto)))
  | -- | MIR are being distributed.
    MIRDistribution MIRDistributionDetails
  | -- | Pools have been reaped and deposits refunded.
    PoolReap PoolReapDetails

class ConvertLedgerEvent blk where
  toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent

instance ConvertLedgerEvent ByronBlock where
  toLedgerEvent :: WrapLedgerEvent ByronBlock -> Maybe LedgerEvent
toLedgerEvent WrapLedgerEvent ByronBlock
_ = Maybe LedgerEvent
forall a. Maybe a
Nothing

instance
  ( Crypto ledgerera ~ StandardCrypto,
    Event (Ledger.Core.EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
    Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
    Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ EpochEvent ledgerera,
    Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ PoolreapEvent ledgerera,
    Event (Ledger.Core.EraRule "MIR" ledgerera) ~ MirEvent ledgerera,
    Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera)
  ) =>
  ConvertLedgerEvent (ShelleyBlock protocol ledgerera)
  where
  toLedgerEvent :: WrapLedgerEvent (ShelleyBlock protocol ledgerera)
-> Maybe LedgerEvent
toLedgerEvent WrapLedgerEvent (ShelleyBlock protocol ledgerera)
evt = case WrapLedgerEvent (ShelleyBlock protocol ledgerera)
-> AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
forall blk. WrapLedgerEvent blk -> AuxLedgerEvent (LedgerState blk)
unwrapLedgerEvent WrapLedgerEvent (ShelleyBlock protocol ledgerera)
evt of
    LEDeltaRewardEvent e m -> LedgerEvent -> Maybe LedgerEvent
forall a. a -> Maybe a
Just (LedgerEvent -> Maybe LedgerEvent)
-> LedgerEvent -> Maybe LedgerEvent
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map StakeCredential (Set (Reward StandardCrypto)) -> LedgerEvent
IncrementalRewardsDistribution EpochNo
e Map StakeCredential (Set (Reward StandardCrypto))
m
    LERewardEvent e m -> LedgerEvent -> Maybe LedgerEvent
forall a. a -> Maybe a
Just (LedgerEvent -> Maybe LedgerEvent)
-> LedgerEvent -> Maybe LedgerEvent
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map StakeCredential (Set (Reward StandardCrypto)) -> LedgerEvent
RewardsDistribution EpochNo
e Map StakeCredential (Set (Reward StandardCrypto))
m
    LEMirTransfer rp rt rtt ttr ->
      LedgerEvent -> Maybe LedgerEvent
forall a. a -> Maybe a
Just (LedgerEvent -> Maybe LedgerEvent)
-> LedgerEvent -> Maybe LedgerEvent
forall a b. (a -> b) -> a -> b
$
        MIRDistributionDetails -> LedgerEvent
MIRDistribution (MIRDistributionDetails -> LedgerEvent)
-> MIRDistributionDetails -> LedgerEvent
forall a b. (a -> b) -> a -> b
$
          Map StakeCredential Lovelace
-> Map StakeCredential Lovelace
-> Lovelace
-> Lovelace
-> MIRDistributionDetails
MIRDistributionDetails Map StakeCredential Lovelace
rp Map StakeCredential Lovelace
rt Lovelace
rtt Lovelace
ttr
    LERetiredPools r u e -> LedgerEvent -> Maybe LedgerEvent
forall a. a -> Maybe a
Just (LedgerEvent -> Maybe LedgerEvent)
-> LedgerEvent -> Maybe LedgerEvent
forall a b. (a -> b) -> a -> b
$ PoolReapDetails -> LedgerEvent
PoolReap (PoolReapDetails -> LedgerEvent) -> PoolReapDetails -> LedgerEvent
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
-> PoolReapDetails
PoolReapDetails EpochNo
e Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
r Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
u
    AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
_ -> Maybe LedgerEvent
forall a. Maybe a
Nothing

instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) where
  toLedgerEvent :: WrapLedgerEvent (HardForkBlock xs) -> Maybe LedgerEvent
toLedgerEvent =
    NS (K (Maybe LedgerEvent)) xs -> Maybe LedgerEvent
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
      (NS (K (Maybe LedgerEvent)) xs -> Maybe LedgerEvent)
-> (WrapLedgerEvent (HardForkBlock xs)
    -> NS (K (Maybe LedgerEvent)) xs)
-> WrapLedgerEvent (HardForkBlock xs)
-> Maybe LedgerEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ConvertLedgerEvent
-> (forall a.
    ConvertLedgerEvent a =>
    WrapLedgerEvent a -> K (Maybe LedgerEvent) a)
-> NS WrapLedgerEvent xs
-> NS (K (Maybe LedgerEvent)) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (Proxy ConvertLedgerEvent
forall k (t :: k). Proxy t
Proxy @ ConvertLedgerEvent) (Maybe LedgerEvent -> K (Maybe LedgerEvent) a
forall k a (b :: k). a -> K a b
K (Maybe LedgerEvent -> K (Maybe LedgerEvent) a)
-> (WrapLedgerEvent a -> Maybe LedgerEvent)
-> WrapLedgerEvent a
-> K (Maybe LedgerEvent) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapLedgerEvent a -> Maybe LedgerEvent
forall blk.
ConvertLedgerEvent blk =>
WrapLedgerEvent blk -> Maybe LedgerEvent
toLedgerEvent)
      (NS WrapLedgerEvent xs -> NS (K (Maybe LedgerEvent)) xs)
-> (WrapLedgerEvent (HardForkBlock xs) -> NS WrapLedgerEvent xs)
-> WrapLedgerEvent (HardForkBlock xs)
-> NS (K (Maybe LedgerEvent)) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraLedgerEvent xs -> NS WrapLedgerEvent xs
forall (xs :: [*]). OneEraLedgerEvent xs -> NS WrapLedgerEvent xs
getOneEraLedgerEvent
      (OneEraLedgerEvent xs -> NS WrapLedgerEvent xs)
-> (WrapLedgerEvent (HardForkBlock xs) -> OneEraLedgerEvent xs)
-> WrapLedgerEvent (HardForkBlock xs)
-> NS WrapLedgerEvent xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapLedgerEvent (HardForkBlock xs) -> OneEraLedgerEvent xs
forall blk. WrapLedgerEvent blk -> AuxLedgerEvent (LedgerState blk)
unwrapLedgerEvent

--------------------------------------------------------------------------------
-- Event details
--------------------------------------------------------------------------------

-- | Details of fund transfers due to MIR certificates.
--
--   Note that the transfers from reserves to treasury and treasury to reserves
--   are inverse; a transfer of 100 ADA in either direction will result in a net
--   movement of 0, but we include both directions for assistance in debugging.
data MIRDistributionDetails = MIRDistributionDetails
  { MIRDistributionDetails -> Map StakeCredential Lovelace
mirddReservePayouts :: Map StakeCredential Lovelace,
    MIRDistributionDetails -> Map StakeCredential Lovelace
mirddTreasuryPayouts :: Map StakeCredential Lovelace,
    MIRDistributionDetails -> Lovelace
mirddReservesToTreasury :: Lovelace,
    MIRDistributionDetails -> Lovelace
mirddTreasuryToReserves :: Lovelace
  }

data PoolReapDetails = PoolReapDetails
  { PoolReapDetails -> EpochNo
prdEpochNo :: EpochNo,
    -- | Refunded deposits. The pools referenced are now retired, and the
    --   'StakeCredential' accounts are credited with the deposits.
    PoolReapDetails
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
prdRefunded :: Map StakeCredential (Map (Hash StakePoolKey) Lovelace),
    -- | Unclaimed deposits. The 'StakeCredential' referenced in this map is not
    -- actively registered at the time of the pool reaping, and as such the
    -- funds are returned to the treasury.
    PoolReapDetails
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
prdUnclaimed :: Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
  }

--------------------------------------------------------------------------------
-- Patterns for event access
--------------------------------------------------------------------------------

pattern LERewardEvent ::
  ( Crypto ledgerera ~ StandardCrypto,
    Event (Ledger.Core.EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
    Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera
  ) =>
  EpochNo ->
  Map StakeCredential (Set (Reward StandardCrypto)) ->
  AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
pattern $mLERewardEvent :: forall r ledgerera protocol.
(Crypto ledgerera ~ StandardCrypto,
 Event (EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
 Event (EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera) =>
AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
-> (EpochNo
    -> Map StakeCredential (Set (Reward StandardCrypto)) -> r)
-> (Void# -> r)
-> r
LERewardEvent e m <-
  ShelleyLedgerEventTICK
    (NewEpochEvent (TotalRewardEvent e (Map.mapKeys fromShelleyStakeCredential -> m)))

pattern LEDeltaRewardEvent ::
  ( Crypto ledgerera ~ StandardCrypto,
    Event (Ledger.Core.EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
    Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
    Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera)
  ) =>
  EpochNo ->
  Map StakeCredential (Set (Reward StandardCrypto)) ->
  AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
pattern $mLEDeltaRewardEvent :: forall r ledgerera protocol.
(Crypto ledgerera ~ StandardCrypto,
 Event (EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
 Event (EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
 Event (EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera)) =>
AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
-> (EpochNo
    -> Map StakeCredential (Set (Reward StandardCrypto)) -> r)
-> (Void# -> r)
-> r
LEDeltaRewardEvent e m <-
  ShelleyLedgerEventTICK
    (NewEpochEvent (DeltaRewardEvent (RupdEvent e (Map.mapKeys fromShelleyStakeCredential -> m))))

pattern LEMirTransfer ::
  ( Crypto ledgerera ~ StandardCrypto,
    Event (Ledger.Core.EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
    Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
    Event (Ledger.Core.EraRule "MIR" ledgerera) ~ MirEvent ledgerera
  ) =>
  Map StakeCredential Lovelace ->
  Map StakeCredential Lovelace ->
  Lovelace ->
  Lovelace ->
  AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
pattern $mLEMirTransfer :: forall r ledgerera protocol.
(Crypto ledgerera ~ StandardCrypto,
 Event (EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
 Event (EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
 Event (EraRule "MIR" ledgerera) ~ MirEvent ledgerera) =>
AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
-> (Map StakeCredential Lovelace
    -> Map StakeCredential Lovelace -> Lovelace -> Lovelace -> r)
-> (Void# -> r)
-> r
LEMirTransfer rp tp rtt ttr <-
  ShelleyLedgerEventTICK
    ( NewEpochEvent
        ( MirEvent
            ( MirTransfer
                ( InstantaneousRewards
                    (Map.mapKeys fromShelleyStakeCredential . fmap fromShelleyLovelace -> rp)
                    (Map.mapKeys fromShelleyStakeCredential . fmap fromShelleyLovelace -> tp)
                    (fromShelleyDeltaLovelace -> rtt)
                    (fromShelleyDeltaLovelace -> ttr)
                  )
              )
          )
      )

pattern LERetiredPools ::
  ( Crypto ledgerera ~ StandardCrypto,
    Event (Ledger.Core.EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
    Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
    Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ EpochEvent ledgerera,
    Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ PoolreapEvent ledgerera
  ) =>
  Map StakeCredential (Map (Hash StakePoolKey) Lovelace) ->
  Map StakeCredential (Map (Hash StakePoolKey) Lovelace) ->
  EpochNo ->
  AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
pattern $mLERetiredPools :: forall r ledgerera protocol.
(Crypto ledgerera ~ StandardCrypto,
 Event (EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
 Event (EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
 Event (EraRule "EPOCH" ledgerera) ~ EpochEvent ledgerera,
 Event (EraRule "POOLREAP" ledgerera) ~ PoolreapEvent ledgerera) =>
AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
-> (Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
    -> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
    -> EpochNo
    -> r)
-> (Void# -> r)
-> r
LERetiredPools r u e <-
  ShelleyLedgerEventTICK
    ( NewEpochEvent
        ( EpochEvent
            ( PoolReapEvent
                ( RetiredPools
                    (convertRetiredPoolsMap -> r)
                    (convertRetiredPoolsMap -> u)
                    e
                  )
              )
          )
      )

convertRetiredPoolsMap ::
     Map (Ledger.StakeCredential StandardCrypto) (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin)
  -> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
convertRetiredPoolsMap :: Map
  (StakeCredential StandardCrypto)
  (Map (KeyHash 'StakePool StandardCrypto) Coin)
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
convertRetiredPoolsMap =
  (StakeCredential StandardCrypto -> StakeCredential)
-> Map
     (StakeCredential StandardCrypto) (Map (Hash StakePoolKey) Lovelace)
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys StakeCredential StandardCrypto -> StakeCredential
fromShelleyStakeCredential
    (Map
   (StakeCredential StandardCrypto) (Map (Hash StakePoolKey) Lovelace)
 -> Map StakeCredential (Map (Hash StakePoolKey) Lovelace))
-> (Map
      (StakeCredential StandardCrypto)
      (Map (KeyHash 'StakePool StandardCrypto) Coin)
    -> Map
         (StakeCredential StandardCrypto)
         (Map (Hash StakePoolKey) Lovelace))
-> Map
     (StakeCredential StandardCrypto)
     (Map (KeyHash 'StakePool StandardCrypto) Coin)
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash 'StakePool StandardCrypto) Coin
 -> Map (Hash StakePoolKey) Lovelace)
-> Map
     (StakeCredential StandardCrypto)
     (Map (KeyHash 'StakePool StandardCrypto) Coin)
-> Map
     (StakeCredential StandardCrypto) (Map (Hash StakePoolKey) Lovelace)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((KeyHash 'StakePool StandardCrypto -> Hash StakePoolKey)
-> Map (KeyHash 'StakePool StandardCrypto) Lovelace
-> Map (Hash StakePoolKey) Lovelace
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys KeyHash 'StakePool StandardCrypto -> Hash StakePoolKey
StakePoolKeyHash (Map (KeyHash 'StakePool StandardCrypto) Lovelace
 -> Map (Hash StakePoolKey) Lovelace)
-> (Map (KeyHash 'StakePool StandardCrypto) Coin
    -> Map (KeyHash 'StakePool StandardCrypto) Lovelace)
-> Map (KeyHash 'StakePool StandardCrypto) Coin
-> Map (Hash StakePoolKey) Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Lovelace)
-> Map (KeyHash 'StakePool StandardCrypto) Coin
-> Map (KeyHash 'StakePool StandardCrypto) Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Coin -> Lovelace
fromShelleyLovelace)