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

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

import           Bcc.Api.Address (StakeCredential, fromSophieStakeCredential)
import           Bcc.Api.Block (EpochNo)
import           Bcc.Api.Certificate (Certificate)
import           Bcc.Api.KeysSophie (Hash (StakePoolKeyHash), StakePoolKey)
import           Bcc.Api.Value (Entropic, fromSophieDeltaEntropic, fromSophieEntropic)
import qualified Bcc.Ledger.Coin
import qualified Bcc.Ledger.Core as Ledger.Core
import qualified Bcc.Ledger.Credential
import           Bcc.Ledger.Crypto (StandardCrypto)
import           Bcc.Ledger.Era (Crypto)
import qualified Bcc.Ledger.Keys
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           Shardagnostic.Consensus.Cole.Ledger.Block (ColeBlock)
import           Shardagnostic.Consensus.Bcc.Block (HardForkBlock)
import           Shardagnostic.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent)
import           Shardagnostic.Consensus.Ledger.Abstract (LedgerState)
import           Shardagnostic.Consensus.Ledger.Basics (AuxLedgerEvent)
import           Shardagnostic.Consensus.Sophie.Ledger (SophieBlock,
                   SophieLedgerEvent (SophieLedgerEventTICK))
import           Shardagnostic.Consensus.TypeFamilyWrappers
import           Sophie.Spec.Ledger.API (InstantaneousRewards (InstantaneousRewards))
import           Sophie.Spec.Ledger.STS.Epoch (EpochEvent (PoolReapEvent))
import           Sophie.Spec.Ledger.STS.Mir (MirEvent (..))
import           Sophie.Spec.Ledger.STS.NewEpoch (NewEpochEvent (EpochEvent, MirEvent, SumRewards))
import           Sophie.Spec.Ledger.STS.PoolReap (PoolreapEvent (RetiredPools))
import           Sophie.Spec.Ledger.STS.Tick (TickEvent (NewEpochEvent))

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
  | -- | Rewards are being distributed.
    RewardsDistribution EpochNo (Map StakeCredential Entropic)
  | -- | 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 ColeBlock where
  toLedgerEvent :: WrapLedgerEvent ColeBlock -> Maybe LedgerEvent
toLedgerEvent WrapLedgerEvent ColeBlock
_ = 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
  ) =>
  ConvertLedgerEvent (SophieBlock ledgerera)
  where
  toLedgerEvent :: WrapLedgerEvent (SophieBlock ledgerera) -> Maybe LedgerEvent
toLedgerEvent WrapLedgerEvent (SophieBlock ledgerera)
evt = case WrapLedgerEvent (SophieBlock ledgerera)
-> AuxLedgerEvent (LedgerState (SophieBlock ledgerera))
forall blk. WrapLedgerEvent blk -> AuxLedgerEvent (LedgerState blk)
unwrapLedgerEvent WrapLedgerEvent (SophieBlock ledgerera)
evt of
    LESumRewards 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 Entropic -> LedgerEvent
RewardsDistribution EpochNo
e Map StakeCredential Entropic
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 Entropic
-> Map StakeCredential Entropic
-> Entropic
-> Entropic
-> MIRDistributionDetails
MIRDistributionDetails Map StakeCredential Entropic
rp Map StakeCredential Entropic
rt Entropic
rtt Entropic
ttr
    LERetiredPools r u -> 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
$ Map StakeCredential (Map (Hash StakePoolKey) Entropic)
-> Map StakeCredential (Map (Hash StakePoolKey) Entropic)
-> PoolReapDetails
PoolReapDetails Map StakeCredential (Map (Hash StakePoolKey) Entropic)
r Map StakeCredential (Map (Hash StakePoolKey) Entropic)
u
    AuxLedgerEvent (LedgerState (SophieBlock 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 BCC 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 Entropic
reservePayouts :: Map StakeCredential Entropic,
    MIRDistributionDetails -> Map StakeCredential Entropic
treasuryPayouts :: Map StakeCredential Entropic,
    MIRDistributionDetails -> Entropic
reservesToTreasury :: Entropic,
    MIRDistributionDetails -> Entropic
treasuryToReserves :: Entropic
  }

data PoolReapDetails = PoolReapDetails
  { -- | Refunded deposits. The pools referenced are now retired, and the
    --   'StakeCredential' accounts are credited with the deposits.
    PoolReapDetails
-> Map StakeCredential (Map (Hash StakePoolKey) Entropic)
refunded :: Map StakeCredential (Map (Hash StakePoolKey) Entropic),
    -- | 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) Entropic)
unclaimed :: Map StakeCredential (Map (Hash StakePoolKey) Entropic)
  }

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

pattern LESumRewards ::
  ( Crypto ledgerera ~ StandardCrypto,
    Event (Ledger.Core.EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
    Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera
  ) =>
  EpochNo ->
  Map StakeCredential Entropic ->
  AuxLedgerEvent (LedgerState (SophieBlock ledgerera))
pattern $mLESumRewards :: forall r ledgerera.
(Crypto ledgerera ~ StandardCrypto,
 Event (EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
 Event (EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera) =>
AuxLedgerEvent (LedgerState (SophieBlock ledgerera))
-> (EpochNo -> Map StakeCredential Entropic -> r)
-> (Void# -> r)
-> r
LESumRewards e m <-
  SophieLedgerEventTICK
    (NewEpochEvent (SumRewards e (convertSumRewardsMap -> 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 Entropic ->
  Map StakeCredential Entropic ->
  Entropic ->
  Entropic ->
  AuxLedgerEvent (LedgerState (SophieBlock ledgerera))
pattern $mLEMirTransfer :: forall r ledgerera.
(Crypto ledgerera ~ StandardCrypto,
 Event (EraRule "TICK" ledgerera) ~ TickEvent ledgerera,
 Event (EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera,
 Event (EraRule "MIR" ledgerera) ~ MirEvent ledgerera) =>
AuxLedgerEvent (LedgerState (SophieBlock ledgerera))
-> (Map StakeCredential Entropic
    -> Map StakeCredential Entropic -> Entropic -> Entropic -> r)
-> (Void# -> r)
-> r
LEMirTransfer rp tp rtt ttr <-
  SophieLedgerEventTICK
    ( NewEpochEvent
        ( MirEvent
            ( MirTransfer
                ( InstantaneousRewards
                    (convertSumRewardsMap -> rp)
                    (convertSumRewardsMap -> tp)
                    (fromSophieDeltaEntropic -> rtt)
                    (fromSophieDeltaEntropic -> ttr)
                  )
              )
          )
      )

convertSumRewardsMap ::
  Map
    ( Bcc.Ledger.Credential.StakeCredential
        Bcc.Ledger.Crypto.StandardCrypto
    )
    Bcc.Ledger.Coin.Coin ->
  Map StakeCredential Entropic
convertSumRewardsMap :: Map (StakeCredential StandardCrypto) Coin
-> Map StakeCredential Entropic
convertSumRewardsMap =
  (StakeCredential StandardCrypto -> StakeCredential)
-> Map (StakeCredential StandardCrypto) Entropic
-> Map StakeCredential Entropic
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys StakeCredential StandardCrypto -> StakeCredential
fromSophieStakeCredential (Map (StakeCredential StandardCrypto) Entropic
 -> Map StakeCredential Entropic)
-> (Map (StakeCredential StandardCrypto) Coin
    -> Map (StakeCredential StandardCrypto) Entropic)
-> Map (StakeCredential StandardCrypto) Coin
-> Map StakeCredential Entropic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Entropic)
-> Map (StakeCredential StandardCrypto) Coin
-> Map (StakeCredential StandardCrypto) Entropic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Coin -> Entropic
fromSophieEntropic

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) Entropic) ->
  Map StakeCredential (Map (Hash StakePoolKey) Entropic) ->
  AuxLedgerEvent (LedgerState (SophieBlock ledgerera))
pattern $mLERetiredPools :: forall r ledgerera.
(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 (SophieBlock ledgerera))
-> (Map StakeCredential (Map (Hash StakePoolKey) Entropic)
    -> Map StakeCredential (Map (Hash StakePoolKey) Entropic) -> r)
-> (Void# -> r)
-> r
LERetiredPools r u <-
  SophieLedgerEventTICK
    ( NewEpochEvent
        ( EpochEvent
            ( PoolReapEvent
                ( RetiredPools
                    (convertRetiredPoolsMap -> r)
                    (convertRetiredPoolsMap -> u)
                  )
              )
          )
      )

convertRetiredPoolsMap ::
  Map
    ( Bcc.Ledger.Credential.StakeCredential
        Bcc.Ledger.Crypto.StandardCrypto
    )
    ( Map
        (Bcc.Ledger.Keys.KeyHash Bcc.Ledger.Keys.StakePool StandardCrypto)
        Bcc.Ledger.Coin.Coin
    ) ->
  Map StakeCredential (Map (Hash StakePoolKey) Entropic)
convertRetiredPoolsMap :: Map
  (StakeCredential StandardCrypto)
  (Map (KeyHash 'StakePool StandardCrypto) Coin)
-> Map StakeCredential (Map (Hash StakePoolKey) Entropic)
convertRetiredPoolsMap =
  (StakeCredential StandardCrypto -> StakeCredential)
-> Map
     (StakeCredential StandardCrypto) (Map (Hash StakePoolKey) Entropic)
-> Map StakeCredential (Map (Hash StakePoolKey) Entropic)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys StakeCredential StandardCrypto -> StakeCredential
fromSophieStakeCredential
    (Map
   (StakeCredential StandardCrypto) (Map (Hash StakePoolKey) Entropic)
 -> Map StakeCredential (Map (Hash StakePoolKey) Entropic))
-> (Map
      (StakeCredential StandardCrypto)
      (Map (KeyHash 'StakePool StandardCrypto) Coin)
    -> Map
         (StakeCredential StandardCrypto)
         (Map (Hash StakePoolKey) Entropic))
-> Map
     (StakeCredential StandardCrypto)
     (Map (KeyHash 'StakePool StandardCrypto) Coin)
-> Map StakeCredential (Map (Hash StakePoolKey) Entropic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash 'StakePool StandardCrypto) Coin
 -> Map (Hash StakePoolKey) Entropic)
-> Map
     (StakeCredential StandardCrypto)
     (Map (KeyHash 'StakePool StandardCrypto) Coin)
-> Map
     (StakeCredential StandardCrypto) (Map (Hash StakePoolKey) Entropic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((KeyHash 'StakePool StandardCrypto -> Hash StakePoolKey)
-> Map (KeyHash 'StakePool StandardCrypto) Entropic
-> Map (Hash StakePoolKey) Entropic
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) Entropic
 -> Map (Hash StakePoolKey) Entropic)
-> (Map (KeyHash 'StakePool StandardCrypto) Coin
    -> Map (KeyHash 'StakePool StandardCrypto) Entropic)
-> Map (KeyHash 'StakePool StandardCrypto) Coin
-> Map (Hash StakePoolKey) Entropic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Entropic)
-> Map (KeyHash 'StakePool StandardCrypto) Coin
-> Map (KeyHash 'StakePool StandardCrypto) Entropic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Coin -> Entropic
fromSophieEntropic)