-
Notifications
You must be signed in to change notification settings - Fork 155
/
PoolReap.hs
98 lines (89 loc) · 2.95 KB
/
PoolReap.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Shelley.Spec.Ledger.STS.PoolReap
( POOLREAP,
PoolreapState (..),
PredicateFailure,
)
where
import Cardano.Prelude (NoUnexpectedThunks (..))
import Control.State.Transition
( STS (..),
TRC (..),
TransitionRule,
judgmentContext,
)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Shelley.Spec.Ledger.BaseTypes (ShelleyBase)
import Shelley.Spec.Ledger.Core (dom, (∈), (∪+), (⋪), (⋫), (▷), (◁))
import Shelley.Spec.Ledger.Delegation.Certificates (StakePools (..))
import Shelley.Spec.Ledger.LedgerState
( AccountState (..),
DState (..),
PState (..),
UTxOState (..),
emptyAccount,
emptyDState,
emptyPState,
emptyUTxOState,
)
import Shelley.Spec.Ledger.PParams (PParams, PParams' (..))
import Shelley.Spec.Ledger.Slot (EpochNo (..))
import Shelley.Spec.Ledger.TxData (_poolRAcnt)
data POOLREAP crypto
data PoolreapState crypto = PoolreapState
{ prUTxOSt :: UTxOState crypto,
prAcnt :: AccountState,
prDState :: DState crypto,
prPState :: PState crypto
}
deriving (Show, Eq)
instance STS (POOLREAP crypto) where
type State (POOLREAP crypto) = PoolreapState crypto
type Signal (POOLREAP crypto) = EpochNo
type Environment (POOLREAP crypto) = PParams
type BaseM (POOLREAP crypto) = ShelleyBase
data PredicateFailure (POOLREAP crypto) -- No predicate Falures
deriving (Show, Eq, Generic)
initialRules =
[ pure $
PoolreapState emptyUTxOState emptyAccount emptyDState emptyPState
]
transitionRules = [poolReapTransition]
instance NoUnexpectedThunks (PredicateFailure (POOLREAP crypto))
poolReapTransition :: TransitionRule (POOLREAP crypto)
poolReapTransition = do
TRC (pp, PoolreapState us a ds ps, e) <- judgmentContext
let retired = dom $ (_retiring ps) ▷ Set.singleton e
StakePools stpools = _stPools ps
pr = Map.fromList $ fmap (\kh -> (kh, _poolDeposit pp)) (Set.toList retired)
rewardAcnts = Map.map _poolRAcnt $ retired ◁ (_pParams ps)
rewardAcnts' =
Map.fromList
. Map.elems
$ Map.intersectionWith (,) rewardAcnts pr
(refunds, mRefunds) =
Map.partitionWithKey
(\k _ -> k ∈ dom (_rewards ds))
rewardAcnts'
refunded = sum $ Map.elems refunds
unclaimed = sum $ Map.elems mRefunds
pure $
PoolreapState
us {_deposited = _deposited us - (unclaimed + refunded)}
a {_treasury = _treasury a + unclaimed}
ds
{ _rewards = _rewards ds ∪+ refunds,
_delegations = _delegations ds ⋫ retired
}
ps
{ _stPools = StakePools $ retired ⋪ stpools,
_pParams = retired ⋪ _pParams ps,
_fPParams = retired ⋪ _fPParams ps,
_retiring = retired ⋪ _retiring ps
}