{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Cardano.Chain.Delegation.Validation.Activation
  ( -- * Activation
    State (..),
    activateDelegation,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen, enforceSize)
import Cardano.Chain.Common (KeyHash)
import qualified Cardano.Chain.Delegation as Delegation
import Cardano.Chain.Delegation.Validation.Scheduling (ScheduledDelegation (..))
import Cardano.Chain.Slotting (SlotNumber (..))
import Cardano.Prelude hiding (State)
import qualified Data.Map.Strict as M
import NoThunks.Class (NoThunks (..))

--------------------------------------------------------------------------------
-- Activation
--------------------------------------------------------------------------------

-- | Maps containing, for each delegator, the active delegation and the slot it
--   became active in.
data State = State
  { State -> Map
delegationMap :: !Delegation.Map,
    State -> Map KeyHash SlotNumber
delegationSlots :: !(Map KeyHash SlotNumber)
  }
  deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show, (forall x. State -> Rep State x)
-> (forall x. Rep State x -> State) -> Generic State
forall x. Rep State x -> State
forall x. State -> Rep State x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep State x -> State
$cfrom :: forall x. State -> Rep State x
Generic, State -> ()
(State -> ()) -> NFData State
forall a. (a -> ()) -> NFData a
rnf :: State -> ()
$crnf :: State -> ()
NFData, Context -> State -> IO (Maybe ThunkInfo)
Proxy State -> String
(Context -> State -> IO (Maybe ThunkInfo))
-> (Context -> State -> IO (Maybe ThunkInfo))
-> (Proxy State -> String)
-> NoThunks State
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy State -> String
$cshowTypeOf :: Proxy State -> String
wNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
noThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> State -> IO (Maybe ThunkInfo)
NoThunks)

instance FromCBOR State where
  fromCBOR :: Decoder s State
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"State" Int
2
    Map -> Map KeyHash SlotNumber -> State
State
      (Map -> Map KeyHash SlotNumber -> State)
-> Decoder s Map -> Decoder s (Map KeyHash SlotNumber -> State)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Map
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (Map KeyHash SlotNumber -> State)
-> Decoder s (Map KeyHash SlotNumber) -> Decoder s State
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map KeyHash SlotNumber)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance ToCBOR State where
  toCBOR :: State -> Encoding
toCBOR State
s =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> Map
delegationMap State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map KeyHash SlotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> Map KeyHash SlotNumber
delegationSlots State
s)

-- | Activate a 'ScheduledDelegation' if its activation slot is less than the
--   previous delegation slot for this delegate, otherwise discard it. This is
--   an implementation of the delegation activation rule in the ledger
--   specification.
activateDelegation :: State -> ScheduledDelegation -> State
activateDelegation :: State -> ScheduledDelegation -> State
activateDelegation State
as ScheduledDelegation
delegation
  | (KeyHash
delegate KeyHash -> Map -> Bool
`Delegation.notMemberR` Map
delegationMap)
      Bool -> Bool -> Bool
&& (SlotNumber
prevDelegationSlot SlotNumber -> SlotNumber -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNumber
slot Bool -> Bool -> Bool
|| SlotNumber -> Word64
unSlotNumber SlotNumber
slot Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0) =
      State :: Map -> Map KeyHash SlotNumber -> State
State
        { delegationMap :: Map
delegationMap = KeyHash -> KeyHash -> Map -> Map
Delegation.insert KeyHash
delegator KeyHash
delegate Map
delegationMap,
          delegationSlots :: Map KeyHash SlotNumber
delegationSlots = KeyHash
-> SlotNumber -> Map KeyHash SlotNumber -> Map KeyHash SlotNumber
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert KeyHash
delegator SlotNumber
slot Map KeyHash SlotNumber
delegationSlots
        }
  | Bool
otherwise = State
as
  where
    State {Map
delegationMap :: Map
delegationMap :: State -> Map
delegationMap, Map KeyHash SlotNumber
delegationSlots :: Map KeyHash SlotNumber
delegationSlots :: State -> Map KeyHash SlotNumber
delegationSlots} = State
as
    ScheduledDelegation SlotNumber
slot KeyHash
delegator KeyHash
delegate = ScheduledDelegation
delegation

    prevDelegationSlot :: SlotNumber
prevDelegationSlot =
      SlotNumber -> Maybe SlotNumber -> SlotNumber
forall a. a -> Maybe a -> a
fromMaybe (Word64 -> SlotNumber
SlotNumber Word64
0) (Maybe SlotNumber -> SlotNumber) -> Maybe SlotNumber -> SlotNumber
forall a b. (a -> b) -> a -> b
$ KeyHash -> Map KeyHash SlotNumber -> Maybe SlotNumber
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup KeyHash
delegator Map KeyHash SlotNumber
delegationSlots