{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeApplications #-}

-- | Examples of the application of the delegation rules.
module Test.Byron.Spec.Ledger.Delegation.Examples (
  deleg,
)
where

import Byron.Spec.Ledger.Core (
  BlockCount (BlockCount),
  Epoch (Epoch),
  Owner (Owner),
  Sig (Sig),
  Slot (Slot),
  VKey (VKey),
  VKeyGenesis (VKeyGenesis),
  owner,
 )
import Byron.Spec.Ledger.Delegation (
  ADELEG,
  ADELEGS,
  DCert (DCert),
  DELEG,
  DIState (DIState),
  DSEnv (DSEnv),
  DSState (DSState),
  DState (DState),
  SDELEG,
  _dIStateDelegationMap,
  _dIStateKeyEpochDelegations,
  _dIStateLastDelegation,
  _dIStateScheduledDelegations,
  _dSEnvAllowedDelegators,
  _dSEnvEpoch,
  _dSEnvK,
  _dSEnvSlot,
 )
import Data.Functor.Identity (runIdentity)
import Data.Set (Set, fromList)
import Data.Word (Word64)
import Numeric.Natural (Natural)
import Test.Control.State.Transition.Trace (checkTrace, (.-), (.->))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

-- | Delegation examples.
deleg :: [TestTree]
deleg :: [TestTree]
deleg =
  [ TestName -> [TestTree] -> TestTree
testGroup
      TestName
"Activation"
      [ TestName -> Assertion -> TestTree
testCase TestName
"Example 0" forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @ADELEG forall a. Identity a -> a
runIdentity Set VKeyGenesis
genKeys forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState [] [])
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
0, (Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10)]
                [(Natural -> VKeyGenesis
gk Natural
0, Word64 -> Slot
s Word64
0)]
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
1, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
11))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10), (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
11)]
                [(Natural -> VKeyGenesis
gk Natural
0, Word64 -> Slot
s Word64
0), (Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
1)]
              -- Here we try to delegate to a key @k 11@ that is already delegated (by
              -- @gk 0@), so the state remains unaltered.
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
2, (Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
11))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10), (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
11)]
                [(Natural -> VKeyGenesis
gk Natural
0, Word64 -> Slot
s Word64
0), (Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
1)]
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
3, (Natural -> VKeyGenesis
gk Natural
2, Natural -> VKey
k Natural
12))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10), (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
11), (Natural -> VKeyGenesis
gk Natural
2, Natural -> VKey
k Natural
12)]
                [(Natural -> VKeyGenesis
gk Natural
0, Word64 -> Slot
s Word64
0), (Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
1), (Natural -> VKeyGenesis
gk Natural
2, Word64 -> Slot
s Word64
3)]
      , TestName -> Assertion -> TestTree
testCase TestName
"Example 1" forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @ADELEG forall a. Identity a -> a
runIdentity Set VKeyGenesis
genKeys forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState [] [])
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
0, (Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
2))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
2)]
                [(Natural -> VKeyGenesis
gk Natural
0, Word64 -> Slot
s Word64
0)]
              -- Trying to delegate to a key that was delegated already has no effect
              -- should be a no-op on the delegation state.
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
1, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
2))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
2)]
                [(Natural -> VKeyGenesis
gk Natural
0, Word64 -> Slot
s Word64
0)]
      , TestName -> Assertion -> TestTree
testCase TestName
"Example 2" forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @ADELEG forall a. Identity a -> a
runIdentity Set VKeyGenesis
genKeys forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState [] [])
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
6, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
2))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
2)]
                [(Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
6)]
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
7, (Natural -> VKeyGenesis
gk Natural
2, Natural -> VKey
k Natural
2))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
2)]
                [(Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
6)]
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
16, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
0))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
0)]
                [(Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
16)]
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- (Word64 -> Slot
s Word64
19, (Natural -> VKeyGenesis
gk Natural
2, Natural -> VKey
k Natural
0))
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
0)]
                [(Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
16)]
      ]
  , TestName -> [TestTree] -> TestTree
testGroup
      TestName
"Multiple Activations"
      [ TestName -> Assertion -> TestTree
testCase TestName
"Example 0" forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @ADELEGS forall a. Identity a -> a
runIdentity Set VKeyGenesis
genKeys forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState [] [])
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- [ (Word64 -> Slot
s Word64
4, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
0))
                 , (Word64 -> Slot
s Word64
5, (Natural -> VKeyGenesis
gk Natural
2, Natural -> VKey
k Natural
0))
                 , (Word64 -> Slot
s Word64
5, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
1))
                 ]
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> Bimap VKeyGenesis VKey -> Map VKeyGenesis Slot -> DState
DState
                [(Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
1)]
                [(Natural -> VKeyGenesis
gk Natural
1, Word64 -> Slot
s Word64
5)]
      ]
  , TestName -> [TestTree] -> TestTree
testGroup
      TestName
"Scheduling"
      [ TestName -> Assertion -> TestTree
testCase TestName
"Example 0" forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @SDELEG forall a. Identity a -> a
runIdentity (Set VKeyGenesis -> Epoch -> Slot -> BlockCount -> DSEnv
DSEnv [Natural -> VKeyGenesis
gk Natural
0, Natural -> VKeyGenesis
gk Natural
1, Natural -> VKeyGenesis
gk Natural
2] (Word64 -> Epoch
e Word64
8) (Word64 -> Slot
s Word64
2) (Word64 -> BlockCount
bk Word64
2160)) forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Slot, (VKeyGenesis, VKey))]
-> Set (Epoch, VKeyGenesis) -> DSState
DSState [] [])
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- VKeyGenesis -> VKey -> Epoch -> DCert
dc (Natural -> VKeyGenesis
gk Natural
0) (Natural -> VKey
k Natural
10) (Word64 -> Epoch
e Word64
8)
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> [(Slot, (VKeyGenesis, VKey))]
-> Set (Epoch, VKeyGenesis) -> DSState
DSState
                [(Word64 -> Slot
s Word64
4322, (Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10))]
                [(Word64 -> Epoch
e Word64
8, Natural -> VKeyGenesis
gk Natural
0)]
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- VKeyGenesis -> VKey -> Epoch -> DCert
dc (Natural -> VKeyGenesis
gk Natural
1) (Natural -> VKey
k Natural
11) (Word64 -> Epoch
e Word64
8)
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> [(Slot, (VKeyGenesis, VKey))]
-> Set (Epoch, VKeyGenesis) -> DSState
DSState
                [(Word64 -> Slot
s Word64
4322, (Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10)), (Word64 -> Slot
s Word64
4322, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
11))]
                [(Word64 -> Epoch
e Word64
8, Natural -> VKeyGenesis
gk Natural
0), (Word64 -> Epoch
e Word64
8, Natural -> VKeyGenesis
gk Natural
1)]
              forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- VKeyGenesis -> VKey -> Epoch -> DCert
dc (Natural -> VKeyGenesis
gk Natural
2) (Natural -> VKey
k Natural
10) (Word64 -> Epoch
e Word64
8)
              forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> [(Slot, (VKeyGenesis, VKey))]
-> Set (Epoch, VKeyGenesis) -> DSState
DSState
                [(Word64 -> Slot
s Word64
4322, (Natural -> VKeyGenesis
gk Natural
0, Natural -> VKey
k Natural
10)), (Word64 -> Slot
s Word64
4322, (Natural -> VKeyGenesis
gk Natural
1, Natural -> VKey
k Natural
11)), (Word64 -> Slot
s Word64
4322, (Natural -> VKeyGenesis
gk Natural
2, Natural -> VKey
k Natural
10))]
                [(Word64 -> Epoch
e Word64
8, Natural -> VKeyGenesis
gk Natural
0), (Word64 -> Epoch
e Word64
8, Natural -> VKeyGenesis
gk Natural
1), (Word64 -> Epoch
e Word64
8, Natural -> VKeyGenesis
gk Natural
2)]
      ]
  , TestName -> [TestTree] -> TestTree
testGroup
      TestName
"Interface"
      [ TestName -> Assertion -> TestTree
testCase TestName
"Non-injective scheduled delegations are ignored." forall a b. (a -> b) -> a -> b
$
          let env :: DSEnv
env =
                DSEnv
                  { _dSEnvAllowedDelegators :: Set VKeyGenesis
_dSEnvAllowedDelegators = [Natural -> VKeyGenesis
gk Natural
0, Natural -> VKeyGenesis
gk Natural
1]
                  , _dSEnvEpoch :: Epoch
_dSEnvEpoch = Word64 -> Epoch
e Word64
0
                  , _dSEnvSlot :: Slot
_dSEnvSlot = Word64 -> Slot
s Word64
21
                  , _dSEnvK :: BlockCount
_dSEnvK = Word64 -> BlockCount
bk Word64
5
                  }
              st :: DIState
st =
                DIState
                  { _dIStateDelegationMap :: Bimap VKeyGenesis VKey
_dIStateDelegationMap =
                      [
                        ( Natural -> VKeyGenesis
gk Natural
0
                        , Natural -> VKey
k Natural
0
                        )
                      ,
                        ( Natural -> VKeyGenesis
gk Natural
1
                        , Natural -> VKey
k Natural
1
                        )
                      ]
                  , _dIStateLastDelegation :: Map VKeyGenesis Slot
_dIStateLastDelegation =
                      [
                        ( Natural -> VKeyGenesis
gk Natural
0
                        , Word64 -> Slot
s Word64
15
                        )
                      ,
                        ( Natural -> VKeyGenesis
gk Natural
1
                        , Word64 -> Slot
s Word64
0
                        )
                      ]
                  , _dIStateScheduledDelegations :: [(Slot, (VKeyGenesis, VKey))]
_dIStateScheduledDelegations =
                      [
                        ( Word64 -> Slot
s Word64
21
                        ,
                          ( Natural -> VKeyGenesis
gk Natural
1
                          , Natural -> VKey
k Natural
0
                          )
                        )
                      ]
                  , _dIStateKeyEpochDelegations :: Set (Epoch, VKeyGenesis)
_dIStateKeyEpochDelegations =
                      forall a. Ord a => [a] -> Set a
fromList
                        [
                          ( Word64 -> Epoch
e Word64
0
                          , Natural -> VKeyGenesis
gk Natural
0
                          )
                        ,
                          ( Word64 -> Epoch
e Word64
0
                          , Natural -> VKeyGenesis
gk Natural
1
                          )
                        ,
                          ( Word64 -> Epoch
e Word64
1
                          , Natural -> VKeyGenesis
gk Natural
0
                          )
                        ]
                  }
           in forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @DELEG forall a. Identity a -> a
runIdentity DSEnv
env forall a b. (a -> b) -> a -> b
$
                forall (f :: * -> *) a. Applicative f => a -> f a
pure DIState
st forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- [] forall (m :: * -> *) st.
(MonadIO m, Eq st, Show st, HasCallStack) =>
m st -> st -> m st
.-> DIState
st {_dIStateScheduledDelegations :: [(Slot, (VKeyGenesis, VKey))]
_dIStateScheduledDelegations = []}
      ]
  ]
  where
    s :: Word64 -> Slot
    s :: Word64 -> Slot
s = Word64 -> Slot
Slot

    k :: Natural -> VKey
    k :: Natural -> VKey
k = Owner -> VKey
VKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Owner
Owner

    gk :: Natural -> VKeyGenesis
    gk :: Natural -> VKeyGenesis
gk = VKey -> VKeyGenesis
VKeyGenesis forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> VKey
k

    e :: Word64 -> Epoch
    e :: Word64 -> Epoch
e = Word64 -> Epoch
Epoch

    bk :: Word64 -> BlockCount
    bk :: Word64 -> BlockCount
bk = Word64 -> BlockCount
BlockCount

    dc :: VKeyGenesis -> VKey -> Epoch -> DCert
    dc :: VKeyGenesis -> VKey -> Epoch -> DCert
dc VKeyGenesis
vkg VKey
vk Epoch
ep = VKeyGenesis -> VKey -> Epoch -> Sig (VKey, Epoch) -> DCert
DCert VKeyGenesis
vkg VKey
vk Epoch
ep (forall a. a -> Owner -> Sig a
Sig (VKey
vk, Epoch
ep) (forall a. HasOwner a => a -> Owner
owner VKeyGenesis
vkg))

    genKeys :: Set VKeyGenesis
    genKeys :: Set VKeyGenesis
genKeys = forall a. Ord a => [a] -> Set a
fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (VKey -> VKeyGenesis
VKeyGenesis forall b c a. (b -> c) -> (a -> b) -> a -> c
. Owner -> VKey
VKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Owner
Owner) [Natural
0 .. Natural
6]