{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Shelley.UnitTests.InstantStakeTest (spec) where

import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (CompactForm, fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential, StakeReference (..))
import Cardano.Ledger.Shelley.State hiding (balance)
import Cardano.Ledger.TxIn (TxIn)
import Data.Default (def)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.MonoTuple (TupleN)
import qualified Data.VMap as VMap
import Lens.Micro
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Shelley.Era
import Test.Cardano.Ledger.Shelley.ImpTest

ppIdL :: Lens' PoolParams (KeyHash 'StakePool)
ppIdL :: Lens' PoolParams (KeyHash 'StakePool)
ppIdL = (PoolParams -> KeyHash 'StakePool)
-> (PoolParams -> KeyHash 'StakePool -> PoolParams)
-> Lens' PoolParams (KeyHash 'StakePool)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PoolParams -> KeyHash 'StakePool
ppId (\PoolParams
x KeyHash 'StakePool
y -> PoolParams
x {ppId = y})

-- | Generate an arbitrary value and overwrite the specified value using the supplied lens.
arbitraryLens :: Arbitrary a => Lens' a b -> b -> Gen a
arbitraryLens :: forall a b. Arbitrary a => Lens' a b -> b -> Gen a
arbitraryLens Lens' a b
l b
b = ((b -> Identity b) -> a -> Identity a
Lens' a b
l ((b -> Identity b) -> a -> Identity a) -> b -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ b
b) (a -> a) -> Gen a -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary

-- ===========================================

instantStakeIncludesRewards :: forall era. ShelleyEraImp era => Gen Property
instantStakeIncludesRewards :: forall era. ShelleyEraImp era => Gen Property
instantStakeIncludesRewards = do
  (PoolParams
pool1, PoolParams
pool2) <- forall a. Arbitrary a => Gen a
arbitrary @(TupleN 2 PoolParams)
  let
    poolId1 :: KeyHash 'StakePool
poolId1 = PoolParams
pool1 PoolParams
-> Getting (KeyHash 'StakePool) PoolParams (KeyHash 'StakePool)
-> KeyHash 'StakePool
forall s a. s -> Getting a s a -> a
^. Getting (KeyHash 'StakePool) PoolParams (KeyHash 'StakePool)
Lens' PoolParams (KeyHash 'StakePool)
ppIdL
    poolId2 :: KeyHash 'StakePool
poolId2 = PoolParams
pool2 PoolParams
-> Getting (KeyHash 'StakePool) PoolParams (KeyHash 'StakePool)
-> KeyHash 'StakePool
forall s a. s -> Getting a s a -> a
^. Getting (KeyHash 'StakePool) PoolParams (KeyHash 'StakePool)
Lens' PoolParams (KeyHash 'StakePool)
ppIdL
  let registerAccount :: KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
registerAccount KeyHash 'StakePool
poolId Accounts era
accounts = do
        Credential 'Staking
stakingCredential <- Gen (Credential 'Staking)
forall a. Arbitrary a => Gen a
arbitrary
        Ptr
ptr <- Gen Ptr
forall a. Arbitrary a => Gen a
arbitrary
        CompactForm Coin
deposit <- Gen (CompactForm Coin)
forall a. Arbitrary a => Gen a
arbitrary
        CompactForm Coin
balance <- Gen (CompactForm Coin)
forall a. Arbitrary a => Gen a
arbitrary
        let accounts' :: Accounts era
accounts' =
              Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
addToBalanceAccounts (Credential 'Staking
-> CompactForm Coin -> Map (Credential 'Staking) (CompactForm Coin)
forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
stakingCredential CompactForm Coin
balance) (Accounts era -> Accounts era) -> Accounts era -> Accounts era
forall a b. (a -> b) -> a -> b
$
                Credential 'Staking
-> Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> Accounts era
-> Accounts era
forall era.
(HasCallStack, EraTest era) =>
Credential 'Staking
-> Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> Accounts era
-> Accounts era
registerTestAccount Credential 'Staking
stakingCredential (Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just Ptr
ptr) CompactForm Coin
deposit (KeyHash 'StakePool -> Maybe (KeyHash 'StakePool)
forall a. a -> Maybe a
Just KeyHash 'StakePool
poolId) Maybe DRep
forall a. Maybe a
Nothing Accounts era
accounts
        (Credential 'Staking, CompactForm Coin, Accounts era)
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Credential 'Staking
stakingCredential, CompactForm Coin
balance, Accounts era
accounts')
  (Credential 'Staking
tom, CompactForm Coin
tomBalance, Accounts era
accounts0) <- KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTest era) =>
KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
registerAccount KeyHash 'StakePool
poolId1 (Accounts era
forall a. Default a => a
def :: Accounts era)
  (Credential 'Staking
john, CompactForm Coin
johnBalance, Accounts era
accounts1) <- KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTest era) =>
KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
registerAccount KeyHash 'StakePool
poolId2 Accounts era
accounts0
  (Credential 'Staking
ann, CompactForm Coin
annBalance, Accounts era
accounts2) <- KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTest era) =>
KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
registerAccount KeyHash 'StakePool
poolId2 Accounts era
accounts1
  (Credential 'Staking
ron, CompactForm Coin
ronBalance, Accounts era
accounts3) <- KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTest era) =>
KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
registerAccount KeyHash 'StakePool
poolId1 Accounts era
accounts2
  (Credential 'Staking
mary, CompactForm Coin
maryBalance, Accounts era
accounts) <- KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTest era) =>
KeyHash 'StakePool
-> Accounts era
-> Gen (Credential 'Staking, CompactForm Coin, Accounts era)
registerAccount KeyHash 'StakePool
poolId2 Accounts era
accounts3
  (Credential 'Payment
tomPay, Credential 'Payment
johnPay, Credential 'Payment
annPay, Credential 'Payment
ronPay) <- forall a. Arbitrary a => Gen a
arbitrary @(TupleN 4 (Credential 'Payment))

  let tomAddr :: Addr
tomAddr = Credential 'Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr Credential 'Payment
tomPay StakeReference
StakeRefNull
      johnAddr :: Addr
johnAddr = Credential 'Payment -> Credential 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr Credential 'Payment
johnPay Credential 'Staking
john
      annAddr :: Addr
annAddr = Credential 'Payment -> Credential 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr Credential 'Payment
annPay Credential 'Staking
ann
      ronAddr :: Addr
ronAddr = Credential 'Payment -> Credential 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr Credential 'Payment
ronPay Credential 'Staking
ron
  -- maryAddr is omitted on purpose. Mary will not have a UTxO entry

  -- Again mary is not included, because she will not have an UTxO entry, but tom will have 2
  (CompactForm Coin
tomCoin1, CompactForm Coin
tomCoin2, CompactForm Coin
johnCoin, CompactForm Coin
annCoin, CompactForm Coin
ronCoin) <- forall a. Arbitrary a => Gen a
arbitrary @(TupleN 5 (CompactForm Coin))

  (TxIn
tomTxIn1, TxIn
tomTxIn2, TxIn
johnTxIn, TxIn
annTxIn, TxIn
ronTxIn) <- forall a. Arbitrary a => Gen a
arbitrary @(TupleN 5 TxIn)

  let
    -- Each wallet (except mary) has one or more UTxO entries
    -- Since tom uses a StakeRefNull those entries will not be distributed
    utxo1 :: UTxO era
utxo1 =
      forall era. Map TxIn (TxOut era) -> UTxO era
UTxO @era
        ( [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (TxIn
tomTxIn1, Addr -> Coin -> TxOut era
forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
tomAddr (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
tomCoin1) -- Not distrubuted, see tomAddr
            , (TxIn
tomTxIn2, Addr -> Coin -> TxOut era
forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
tomAddr (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
tomCoin2) -- Not distributed, see tomAddr
            , (TxIn
annTxIn, Addr -> Coin -> TxOut era
forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
annAddr (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
annCoin)
            , (TxIn
ronTxIn, Addr -> Coin -> TxOut era
forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
ronAddr (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
ronCoin)
            , (TxIn
johnTxIn, Addr -> Coin -> TxOut era
forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
johnAddr (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
johnCoin)
            -- Note Mary does not have a UTxO entry, but her rewards are still counted
            ]
        )
    dState :: DState era
dState = DState era
forall a. Default a => a
def DState era -> (DState era -> DState era) -> DState era
forall a b. a -> (a -> b) -> b
& (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> DState era -> Identity (DState era))
-> Accounts era -> DState era -> DState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Accounts era
accounts

    instantStake :: InstantStake era
instantStake = UTxO era -> InstantStake era -> InstantStake era
forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake UTxO era
utxo1 InstantStake era
forall a. Monoid a => a
mempty
    poolparamMap :: Map (KeyHash 'StakePool) PoolParams
poolparamMap = [(KeyHash 'StakePool, PoolParams)]
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(KeyHash 'StakePool
poolId1, PoolParams
pool1), (KeyHash 'StakePool
poolId2, PoolParams
pool2)]
  PState era
pState <- Lens' (PState era) (Map (KeyHash 'StakePool) StakePoolState)
-> Map (KeyHash 'StakePool) StakePoolState -> Gen (PState era)
forall a b. Arbitrary a => Lens' a b -> b -> Gen a
arbitraryLens (Map (KeyHash 'StakePool) StakePoolState
 -> f (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> f (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) StakePoolState
 -> f (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> f (PState era)
Lens' (PState era) (Map (KeyHash 'StakePool) StakePoolState)
psStakePoolsL (Map (KeyHash 'StakePool) StakePoolState -> Gen (PState era))
-> Map (KeyHash 'StakePool) StakePoolState -> Gen (PState era)
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> PoolParams -> StakePoolState
mkStakePoolState CompactForm Coin
forall a. Monoid a => a
mempty (PoolParams -> StakePoolState)
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) StakePoolState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (KeyHash 'StakePool) PoolParams
poolparamMap
  let snapShot :: SnapShot
snapShot = InstantStake era -> DState era -> PState era -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake InstantStake era
instantStake DState era
dState PState era
pState
      computedStakeDistr :: Map (Credential 'Staking) (CompactForm Coin)
computedStakeDistr = VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake (SnapShot -> Stake
ssStake SnapShot
snapShot))

      expectedStakeDistr :: Map (Credential 'Staking) (CompactForm Coin)
      expectedStakeDistr :: Map (Credential 'Staking) (CompactForm Coin)
expectedStakeDistr =
        [(Credential 'Staking, CompactForm Coin)]
-> Map (Credential 'Staking) (CompactForm Coin)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Credential 'Staking, CompactForm Coin)]
 -> Map (Credential 'Staking) (CompactForm Coin))
-> [(Credential 'Staking, CompactForm Coin)]
-> Map (Credential 'Staking) (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$
          [ (Credential 'Staking, CompactForm Coin)
stake
          | stake :: (Credential 'Staking, CompactForm Coin)
stake@(Credential 'Staking
_, CompactForm Coin
balance) <-
              [ (Credential 'Staking
ann, CompactForm Coin
annBalance CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
annCoin)
              , (Credential 'Staking
ron, CompactForm Coin
ronBalance CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
ronCoin)
              , (Credential 'Staking
john, CompactForm Coin
johnBalance CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
johnCoin)
              , (Credential 'Staking
tom, CompactForm Coin
tomBalance)
              , (Credential 'Staking
mary, CompactForm Coin
maryBalance)
              ]
          , -- We need to filter out zero rewards from instant stake, since all coins are
          -- generated at random, stake for any one of the accounts can be zero
          CompactForm Coin
balance CompactForm Coin -> CompactForm Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= CompactForm Coin
forall a. Monoid a => a
mempty
          ]

  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (Credential 'Staking) (CompactForm Coin)
computedStakeDistr Map (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) (CompactForm Coin) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map (Credential 'Staking) (CompactForm Coin)
expectedStakeDistr)

spec :: forall era. ShelleyEraImp era => Spec
spec :: forall era. ShelleyEraImp era => Spec
spec = String -> Gen Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"InstantStakeIncludesRewards" (forall era. ShelleyEraImp era => Gen Property
instantStakeIncludesRewards @era)