From 209a091a3eb03b60840de2d01bcc2a5c05151212 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Wed, 3 Feb 2021 12:29:45 -0800 Subject: [PATCH 01/18] Added Data.Pulse to the semantics library. --- semantics/executable-spec/small-steps.cabal | 1 + semantics/executable-spec/src/Data/Pulse.hs | 248 ++++++++++++++++++++ 2 files changed, 249 insertions(+) create mode 100644 semantics/executable-spec/src/Data/Pulse.hs diff --git a/semantics/executable-spec/small-steps.cabal b/semantics/executable-spec/small-steps.cabal index 5bddfc9b59..1d15c6fdea 100644 --- a/semantics/executable-spec/small-steps.cabal +++ b/semantics/executable-spec/small-steps.cabal @@ -34,6 +34,7 @@ library , Data.CanonicalMaps , Data.MemoBytes , Data.Coders + , Data.Pulse , Control.Provenance , Control.Iterate.SetAlgebra , Control.Iterate.Collect diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs new file mode 100644 index 0000000000..10e5cc8727 --- /dev/null +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Pulse where + +import qualified Data.List as List +import Data.Kind +import Data.Map(Map) +import qualified Data.Map.Strict as Map +import Data.Map.Internal (Map (..), link, link2) +import Control.Monad.Identity(Identity(..)) + +-- ==================================================== + + +{- | let T be a Pulse structure. A Pulse struture + is abstracted over a monad: m, and an answer type: t, + so the concrete type of a pulse structure is written: (T m a). + The Pulsable class supplies operations on the structure + that allow its computation to be split into many discrete + steps. One does this by running: "pulse p" or "pulseM p", + depending upon whether the computation is monadic or not, + to run a discrete step. The scheduling infrastructure needs + to know nothing about what is going on inside the pulse structure. +-} +class Pulsable (pulse :: (Type -> Type) -> Type -> Type) where + done :: pulse m ans -> Bool + current :: pulse m ans -> ans + pulseM :: Monad m => pulse m ans -> m(pulse m ans) + completeM :: Monad m => pulse m ans -> m ans + completeM p = + do p' <- pulseM p + if done p' then pure(current p') else completeM p' + +-- ================================= +-- Pulse structure for List in an arbitray monad + +data PulseListM m ans where + PulseList:: Assoc -> !Int -> !(ans -> a -> m ans) -> ![a] -> !ans -> PulseListM m ans + +instance Show ans => Show (PulseListM m ans) where + show(PulseList ass n _ t a) = "(Pulse "++assoc ass++show n++status t++show a++")" + where status [] = " Done " + status (x : _) = " More " + assoc LeftA = "left " + assoc RightA = "right " + +-- ================================= +-- Pulse structure for Map in an arbitray monad + +data PulseMapM m ans where + PulseMap:: !Int -> !(ans -> k -> v -> m ans) -> !(Map k v) -> !ans -> PulseMapM m ans + +instance Show ans => Show (PulseMapM m ans) where + show(PulseMap n _ t a) = "(Pulse "++show n++status t++show a++")" + where status x = if Map.null x then " Done " else " More " + +-- =============================================================== +-- Pulse structures can be Specialize to the Identity Monad + +type PulseList ans = PulseListM Identity ans +type PulseMap ans = PulseListM Identity ans + +-- Use these 'pseudo constructors' to construct Pulse structures in +-- the identity monad. They automatically lift the accumulating function + +pulseList:: Assoc -> Int -> (t1 -> t2 -> t1) -> [t2] -> t1 -> PulseListM Identity t1 +pulseList LeftA n accum xs zero = + PulseList LeftA n (\ ans x -> Identity(accum ans x)) xs zero +pulseList RightA n accum xs zero = + PulseList RightA n (\ ans x -> Identity(accum ans x)) (reverse xs) zero + + +pulseMap:: Int -> (a -> k -> v -> a) -> Map k v -> a -> PulseMapM Identity a +pulseMap n accum ts zero = PulseMap n (\ ans k v -> Identity(accum ans k v)) ts zero + +-- run Pulse structures in the Identity monad. + +pulse :: Pulsable p => p Identity ans -> p Identity ans +pulse p = runIdentity (pulseM p) + +complete :: Pulsable p => p Identity ans -> ans +complete p = runIdentity (completeM p) + +-- ================================================= +-- Some instances + +instance Pulsable PulseListM where + done (PulseList _ _ _ [] _) = True + done (PulseList _ _ _ (_: _) _) = False + current (PulseList _ _ _ _ ans) = ans + pulseM (PulseList ass n accum balance ans) = do + let (steps, balance') = List.splitAt n balance + ans' <- (foldM' ass) accum ans steps + pure (PulseList ass n accum balance' ans') + +instance Pulsable PulseMapM where + done (PulseMap _ _ m _) = Map.null m + current (PulseMap _ _ _ ans) = ans + pulseM (PulseMap n accum balance ans) = do + let (steps, balance') = Map.splitAt n balance + ans' <- foldlWithKeyM' accum ans steps + pure (PulseMap n accum balance' ans') + +-- ================================================================ +-- Special monadic folds for use with PulseListM and PulseMapM +-- They are strict, monadic, and their arguments are in the right order. +-- These functions should appear somewhere in Data.List or Data.List or +-- Data.Foldable or Data.Traversable, or Control.Monad, but they don't. + +-- | A strict, monadic, version of 'foldl' for lists. It associates to the left. +foldlM' :: Monad m => (ans -> k -> m ans) -> ans -> [k] -> m ans +foldlM' _accum !ans [] = pure ans +foldlM' accum !ans (k:more) = do { ans1 <- accum ans k; foldlM' accum ans1 more } + + +-- | A strict, monadic, version of 'foldlr' for lists. It associates to the right. +foldrM' :: Monad m => (ans -> k -> m ans) -> ans -> [k] -> m ans +foldrM' _accum !ans [] = pure ans +foldrM' accum !ans (k : more) = do !ans1 <- foldrM' accum ans more; accum ans1 k + +data Assoc = LeftA | RightA + +-- | Choose either asscociating to the left or right. +foldM' :: Monad m => Assoc -> (ans -> k -> m ans) -> ans -> [k] -> m ans +foldM' LeftA = foldlM' +foldM' RightA = foldrM' + +-- | /O(n)/. A strict, monadic, version of 'foldlWithKey'. Each application of the +-- operator is evaluated before using the result in the next application. This +-- function is strict in the starting value. Associates to the left. +foldlWithKeyM' :: Monad m => (a -> k -> b -> m a) -> a -> Map k b -> m a +foldlWithKeyM' f z = go z + where + go !z' Tip = pure z' + go z' (Bin _ kx x l r) = + do !ans1 <- (go z' l) + !ans2 <- (f ans1 kx x) + go ans2 r + +-- ====================================================== +-- Two examples + +isum :: PulseListM Identity Integer +isum = pulseList RightA 10 (+) [1..33] 0 + +{- Note how we start adding the last 10 elements +*Pulse> isum +(Pulse right 10 More 0) +*Pulse> pulse it +(Pulse right 10 More 285) +*Pulse> pulse it +(Pulse right 10 More 470) +*Pulse> pulse it +(Pulse right 10 More 555) +*Pulse> pulse it +(Pulse right 10 Done 561) +-} + + +jsum :: PulseListM Identity Integer +jsum = pulseList LeftA 10 (+) [1..33] 0 + +{- Here we are adding the first 10 elements +*Pulse> jsum +(Pulse left 10 More 0) +*Pulse> pulse it +(Pulse left 10 More 55) +*Pulse> pulse it +(Pulse left 10 More 210) +*Pulse> pulse it +(Pulse left 10 More 465) +*Pulse> pulse it +(Pulse left 10 Done 561) +-} + +ksum = pulseList RightA 1 (+) [1..5] 0 +{- +*Pulse> ksum +(Pulse right 1 More 0) +*Pulse> pulse it +(Pulse right 1 More 5) +*Pulse> pulse it +(Pulse right 1 More 9) +*Pulse> pulse it +(Pulse right 1 More 12) +*Pulse> pulse it +(Pulse right 1 More 14) +*Pulse> pulse it +(Pulse right 1 Done 15) +-} + +hsum = pulseList LeftA 1 (+) [1..5] 0 +{- +*Pulse> hsum +(Pulse left 1 More 0) +*Pulse> pulse it +(Pulse left 1 More 1) +*Pulse> pulse it +(Pulse left 1 More 3) +*Pulse> pulse it +(Pulse left 1 More 6) +*Pulse> pulse it +(Pulse left 1 More 10) +*Pulse> pulse it +(Pulse left 1 Done 15) +-} + +msum :: PulseMapM Identity (Map Char Integer) +msum = pulseMap 2 + (\ a k n -> Map.insertWith (+) k n a) + (Map.fromList [(c,1) | c <- "abcdefg"]) + (Map.fromList [('z',1),('d',1),('g',1)]) + +{- +Pulse> msum +(Pulse 2 More fromList [('d',1),('g',1),('z',1)]) +*Pulse> pulse it +(Pulse 2 More fromList [('a',1),('b',1),('d',1),('g',1),('z',1)]) +*Pulse> pulse it +(Pulse 2 More fromList [('a',1),('b',1),('c',1),('d',2),('g',1),('z',1)]) +*Pulse> pulse it +(Pulse 2 More fromList [('a',1),('b',1),('c',1),('d',2),('e',1),('f',1),('g',1),('z',1)]) +*Pulse> pulse it +(Pulse 2 Done fromList [('a',1),('b',1),('c',1),('d',2),('e',1),('f',1),('g',2),('z',1)]) +-} + + +iosum :: PulseListM IO () +iosum = PulseList LeftA 2 (\ () k -> putStrLn (show k)) [1..5] () +{- +*Pulse> iosum +(Pulse left 2 More ()) +*Pulse> pulseM it +1 +2 +(Pulse left 2 More ()) +*Pulse> pulseM it +3 +4 +(Pulse left 2 More ()) +*Pulse> pulseM it +5 +(Pulse left 2 Done ()) +-} \ No newline at end of file From 59420e797b1949bc837d503050e99a6e098d3f24 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Wed, 3 Feb 2021 12:33:45 -0800 Subject: [PATCH 02/18] removed warnings --- semantics/executable-spec/src/Data/Pulse.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index 10e5cc8727..9d009fe4ef 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -4,13 +4,13 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -module Pulse where +module Data.Pulse where import qualified Data.List as List import Data.Kind import Data.Map(Map) import qualified Data.Map.Strict as Map -import Data.Map.Internal (Map (..), link, link2) +import Data.Map.Internal (Map (..)) import Control.Monad.Identity(Identity(..)) -- ==================================================== @@ -44,7 +44,7 @@ data PulseListM m ans where instance Show ans => Show (PulseListM m ans) where show(PulseList ass n _ t a) = "(Pulse "++assoc ass++show n++status t++show a++")" where status [] = " Done " - status (x : _) = " More " + status (_ : _) = " More " assoc LeftA = "left " assoc RightA = "right " @@ -177,6 +177,7 @@ jsum = pulseList LeftA 10 (+) [1..33] 0 (Pulse left 10 Done 561) -} +ksum :: PulseList Integer ksum = pulseList RightA 1 (+) [1..5] 0 {- *Pulse> ksum @@ -193,6 +194,7 @@ ksum = pulseList RightA 1 (+) [1..5] 0 (Pulse right 1 Done 15) -} +hsum :: PulseList Integer hsum = pulseList LeftA 1 (+) [1..5] 0 {- *Pulse> hsum @@ -230,7 +232,7 @@ Pulse> msum iosum :: PulseListM IO () -iosum = PulseList LeftA 2 (\ () k -> putStrLn (show k)) [1..5] () +iosum = PulseList LeftA 2 (\ () k -> putStrLn (show k)) [(1::Int)..5] () {- *Pulse> iosum (Pulse left 2 More ()) From 0caf04e14fe80a76399b3995366849b2c69b1e3c Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Thu, 4 Feb 2021 17:47:47 -0800 Subject: [PATCH 03/18] Added the class MAccum in Data.Pulse to make first order pulsable data. Simple exampe in that file, and an exampke for dong the full reward calculation at the end of the file for Shelley.Spec.Ledger.Rewards. --- semantics/executable-spec/src/Data/Pulse.hs | 107 ++++++++++++++++-- .../src/Shelley/Spec/Ledger/Rewards.hs | 93 ++++++++++++++- 2 files changed, 191 insertions(+), 9 deletions(-) diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index 9d009fe4ef..54050ab0eb 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -3,6 +3,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} + module Data.Pulse where @@ -12,6 +18,10 @@ import Data.Map(Map) import qualified Data.Map.Strict as Map import Data.Map.Internal (Map (..)) import Control.Monad.Identity(Identity(..)) +import Data.Coders +import Cardano.Binary(ToCBOR(..),FromCBOR(..)) +import Data.Typeable + -- ==================================================== @@ -43,11 +53,16 @@ data PulseListM m ans where instance Show ans => Show (PulseListM m ans) where show(PulseList ass n _ t a) = "(Pulse "++assoc ass++show n++status t++show a++")" - where status [] = " Done " - status (_ : _) = " More " - assoc LeftA = "left " + where assoc LeftA = "left " assoc RightA = "right " +isNil :: [a] -> Bool +isNil [] = True +isNil (_ : _) = False + +status :: [a] -> String +status x = if isNil x then " Done " else " More " + -- ================================= -- Pulse structure for Map in an arbitray monad @@ -55,8 +70,8 @@ data PulseMapM m ans where PulseMap:: !Int -> !(ans -> k -> v -> m ans) -> !(Map k v) -> !ans -> PulseMapM m ans instance Show ans => Show (PulseMapM m ans) where - show(PulseMap n _ t a) = "(Pulse "++show n++status t++show a++")" - where status x = if Map.null x then " Done " else " More " + show(PulseMap n _ t a) = + "(Pulse "++show n++(if Map.null t then " Done " else " More ")++show a++")" -- =============================================================== -- Pulse structures can be Specialize to the Identity Monad @@ -89,8 +104,7 @@ complete p = runIdentity (completeM p) -- Some instances instance Pulsable PulseListM where - done (PulseList _ _ _ [] _) = True - done (PulseList _ _ _ (_: _) _) = False + done (PulseList _ _ _ zs _) = isNil zs current (PulseList _ _ _ _ ans) = ans pulseM (PulseList ass n accum balance ans) = do let (steps, balance') = List.splitAt n balance @@ -247,4 +261,81 @@ iosum = PulseList LeftA 2 (\ () k -> putStrLn (show k)) [(1::Int)..5] () *Pulse> pulseM it 5 (Pulse left 2 Done ()) --} \ No newline at end of file +-} + +{- +Need to serialize + +-} + +-- ========================================================= +-- Every instance of MAccum, refers to exactly one function + +class MAccum unique (m :: Type -> Type) free item ans | unique -> m free item ans where + maccum :: unique -> free -> ans -> item -> m ans + +-- Here is an example instance + +-- Make a Unique Unit type. (I.e. an enumeration with one constructor) +data XXX = XXX + deriving Show + +instance ToCBOR XXX where toCBOR XXX = encode(Rec XXX) +instance FromCBOR XXX where fromCBOR = decode(RecD XXX) + +-- | The unique 'maccum' function of the (MAccum XXX _ _ _ _) instance + +fooAccum :: [a] -> Int -> Int -> Identity Int +fooAccum bs ans v = Identity (v+ans + length bs) + +instance MAccum XXX Identity [Bool] Int Int where + maccum XXX = fooAccum + +-- ========================================================= +-- LL is a first order data type (no embedded functions) +-- that can be given a (Pulsable (LL name)) instance, We +-- can also make ToCBOR and FromCBOR instances for it. + +data LL name (m :: Type -> Type) ans where + LL:: (MAccum name m free v ans, ToCBOR v, ToCBOR free) => + name -> !Int -> !free -> ![v] -> !ans -> LL name m ans + +instance (Show ans, Show name) => Show (LL name m ans) where + show (LL name n _ vs ans) = "(LL "++show name++" "++show n++status vs++" "++show ans++")" + + +-- There is a single ToCBOR instance for (LL name m ans) +-- But because of the uniqueness of the name, which implies +-- the hidden types (free and v for LL), We must supply +-- a unique FromCBOR instance for each name. See the XXX example below. + +instance (Typeable m, ToCBOR name, ToCBOR ans) => ToCBOR (LL name m ans) where + toCBOR (LL name n free vs ans) = encode(Rec (LL name) !> To n !> To free !> To vs !> To ans) + +instance Pulsable (LL name) where + done (LL _name _n _free zs _ans) = isNil zs + current (LL _ _ _ _ ans) = ans + pulseM (LL name n free balance ans) = do + let (steps, balance') = List.splitAt n balance + ans' <- foldlM' (maccum name free) ans steps + pure (LL name n free balance' ans') + + +-- ================================================= +-- To make a serializable type that has a (Pulsable (LL name)) instance, +-- first, define a Unit type (an enumeration with 1 constructor). +-- This will have a unique MAccum instance, which +-- will refer to a unique function with no free variables. +-- If we follow the pattern below, then the Pulsable instance +-- will refer to that (MAccum) instance, but will store only +-- first order data. + +-- We must supply a unique FromCBOR instance for each 'name'. The 'name' +-- fixes the monad 'm' and 'ans' type, as well as the 'maccum' function +-- for XXX at the value level. + +instance FromCBOR (LL XXX Identity Int) where + fromCBOR = decode (RecD (LL XXX) )) import Cardano.Slotting.Slot (EpochSize) import Control.DeepSeq (NFData) @@ -98,6 +105,9 @@ import Shelley.Spec.Ledger.Serialization encodeFoldable, ) import Shelley.Spec.Ledger.TxBody (PoolParams (..), getRwdCred) +import Data.Pulse(LL(..),MAccum(..)) +import Data.Kind(Type) +import Data.Typeable newtype LogWeight = LogWeight {unLogWeight :: Float} deriving (Eq, Generic, Ord, Num, NFData, NoThunks, ToCBOR, FromCBOR) @@ -661,3 +671,84 @@ nonMyopicMemberRew f = maxPool pp rPot (unStakeShare nm) (unStakeShare s) fHat = floor (p * (fromRational . coinToRational) f) in memberRew (Coin fHat) pool t nm + + +-- ========================================== + + +data FreeVars era = + FreeVars{ b:: Map (KeyHash 'StakePool (Crypto era)) Natural, + delegs:: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)), + stake:: Stake (Crypto era), + addrsRew :: Set (Credential 'Staking (Crypto era)), + totalStake :: Integer, + activeStake :: Integer, + asc :: ActiveSlotCoeff, + totalBlocks :: Natural, -- + r :: Coin, + pp :: PParams era, + slotsPerEpoch :: EpochSize } + + +actionFree + :: (Monad m) => + FreeVars era + -> ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))) + , Map (KeyHash 'StakePool (Crypto era)) Likelihood) + -> (KeyHash 'StakePool (Crypto era), PoolParams (Crypto era)) + -> ProvM + (Map + (KeyHash 'StakePool (Crypto era)) + (RewardProvenancePool (Crypto era))) + m + ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))) + , Map (KeyHash 'StakePool (Crypto era)) Likelihood) +actionFree (FreeVars{b,delegs,stake,addrsRew,totalStake,activeStake,asc,totalBlocks,r,pp,slotsPerEpoch}) + (m1, m2) (hk, pparams) = do + let blocksProduced = Map.lookup hk b + actgr@(Stake s) = poolStake hk delegs stake + Coin pstake = fold s + sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake + sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake + ls = + likelihood + (fromMaybe 0 blocksProduced) + (leaderProbability asc sigma (_d pp)) + slotsPerEpoch + case blocksProduced of + Nothing -> pure (m1, Map.insert hk ls m2) + Just n -> do + m <- rewardOnePool pp r n totalBlocks pparams actgr sigma sigmaA (Coin totalStake) addrsRew + pure (Map.unionWith Set.union m m1, Map.insert hk ls m2) + +data RewardCalc (m:: Type -> Type) era c = RewardCalc + +instance (Monad m, c ~ Crypto era) => + MAccum (RewardCalc m era c) + (ProvM (Map (KeyHash 'StakePool c) (RewardProvenancePool c)) m) + (FreeVars era) + (KeyHash 'StakePool c, PoolParams c) + ( Map (Credential 'Staking c) (Set (Reward c)), + Map (KeyHash 'StakePool c) Likelihood ) + where maccum RewardCalc = actionFree + +-- Make an example LL + +instance Typeable era => ToCBOR (FreeVars era) where + toCBOR _x = undefined + +freevars :: FreeVars era +freevars = undefined + +rewardLL :: (Monad m, Era era) => + LL + (RewardCalc m era (Crypto era)) + (ProvM + (Map + (KeyHash 'StakePool (Crypto era)) + (RewardProvenancePool (Crypto era))) + m) + (Map + (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), + Map (KeyHash 'StakePool (Crypto era)) Likelihood) +rewardLL = LL RewardCalc 10 freevars [] (Map.empty, Map.empty) \ No newline at end of file From 6351a0457268ec7b936bd69d54e7c4f065133eb2 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Fri, 5 Feb 2021 12:38:09 -0800 Subject: [PATCH 04/18] Integrated pulsing into the reward calculation. --- semantics/executable-spec/src/Data/Coders.hs | 20 ++ semantics/executable-spec/src/Data/Pulse.hs | 5 +- .../src/Shelley/Spec/Ledger/API/Wallet.hs | 1 + .../src/Shelley/Spec/Ledger/LedgerState.hs | 2 +- .../src/Shelley/Spec/Ledger/Orphans.hs | 6 +- .../src/Shelley/Spec/Ledger/Rewards.hs | 197 ++++++++---------- .../test/Test/Shelley/Spec/Ledger/Rewards.hs | 12 +- 7 files changed, 129 insertions(+), 114 deletions(-) diff --git a/semantics/executable-spec/src/Data/Coders.hs b/semantics/executable-spec/src/Data/Coders.hs index 38e9800791..e0f7b7845e 100644 --- a/semantics/executable-spec/src/Data/Coders.hs +++ b/semantics/executable-spec/src/Data/Coders.hs @@ -78,6 +78,10 @@ module Data.Coders encodeNullMaybe, decodeNullMaybe, decodeSparse, + toMap, + fromMap, + toSet, + fromSet, ) where @@ -109,6 +113,7 @@ import Cardano.Binary import qualified Data.Sequence as Seq import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Text as Text import Data.Sequence.Strict (StrictSeq) import Data.Sequence (Seq) @@ -610,6 +615,21 @@ to xs = ED dualCBOR xs from :: (ToCBOR t, FromCBOR t) => Decode ('Closed 'Dense) t from = DD dualCBOR + +-- Names for derived Encode and Decode combinators for Sets and Maps + +toMap :: (ToCBOR v) => Map.Map k v -> Encode ('Closed 'Dense) (Map.Map k v) +toMap x = E encodeFoldable x + +fromMap:: (Ord k,FromCBOR k,FromCBOR v) => Decode ('Closed 'Dense) (Map.Map k v) +fromMap = From + +toSet :: (ToCBOR v) => Set.Set v -> Encode ('Closed 'Dense) (Set.Set v) +toSet x = E encodeFoldable x + +fromSet :: (Ord v,FromCBOR v) => Decode ('Closed 'Dense) (Set.Set v) +fromSet = D (decodeSet fromCBOR) + -- ================================================================== -- A Guide to Visual inspection of Duality in Encode and Decode -- diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index 54050ab0eb..b47d5ac4de 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -106,6 +106,7 @@ complete p = runIdentity (completeM p) instance Pulsable PulseListM where done (PulseList _ _ _ zs _) = isNil zs current (PulseList _ _ _ _ ans) = ans + pulseM (ll@(PulseList _ _ _ balance _)) | isNil balance = pure ll pulseM (PulseList ass n accum balance ans) = do let (steps, balance') = List.splitAt n balance ans' <- (foldM' ass) accum ans steps @@ -114,6 +115,7 @@ instance Pulsable PulseListM where instance Pulsable PulseMapM where done (PulseMap _ _ m _) = Map.null m current (PulseMap _ _ _ ans) = ans + pulseM (ll@(PulseMap _ _ balance _)) | Map.null balance = pure ll pulseM (PulseMap n accum balance ans) = do let (steps, balance') = Map.splitAt n balance ans' <- foldlWithKeyM' accum ans steps @@ -315,11 +317,12 @@ instance (Typeable m, ToCBOR name, ToCBOR ans) => ToCBOR (LL name m ans) where instance Pulsable (LL name) where done (LL _name _n _free zs _ans) = isNil zs current (LL _ _ _ _ ans) = ans + pulseM (ll@(LL _ _ _ [] _)) = pure ll pulseM (LL name n free balance ans) = do let (steps, balance') = List.splitAt n balance ans' <- foldlM' (maccum name free) ans steps pure (LL name n free balance' ans') - + completeM (LL name _ free balance ans) = foldlM' (maccum name free) ans balance -- ================================================= -- To make a serializable type that has a (Pulsable (LL name)) instance, diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs index 6119e540b7..b1a5de8c55 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs @@ -254,6 +254,7 @@ getPoolParameters nes poolId = Map.lookup poolId (f nes) getRewardInfo :: forall era. + Era era => Globals -> NewEpochState era -> (RewardUpdate (Crypto era), RewardProvenance (Crypto era)) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 749e816db3..3fe98f4884 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -1075,7 +1075,7 @@ updateNonMyopic nm rPot newLikelihoods = -- | Create a reward update createRUpd :: - forall era. + forall era. Era era => EpochSize -> BlocksMade (Crypto era) -> EpochState era -> diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs index aa125a131b..04c0224d52 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs @@ -11,7 +11,7 @@ import qualified Cardano.Crypto.Hash.Class as HS import Cardano.Crypto.Util (SignableRepresentation (..)) import qualified Cardano.Crypto.Wallet as WC import Cardano.Prelude (HeapWords (..), readEither) -import Cardano.Slotting.Slot (WithOrigin (..)) +import Cardano.Slotting.Slot (WithOrigin (..), EpochSize(..)) import Control.DeepSeq (NFData (rnf)) import Data.Aeson import qualified Data.ByteString as Long (ByteString, empty) @@ -27,6 +27,7 @@ import NoThunks.Class (NoThunks (..)) import Shelley.Spec.Ledger.BaseTypes (Network (..), StrictMaybe (..), UnitInterval, interval0) import Shelley.Spec.Ledger.Keys (KeyHash (..)) import Shelley.Spec.Ledger.Slot (BlockNo, EpochNo) +import Cardano.Binary(ToCBOR,FromCBOR) instance FromJSON IPv4 where parseJSON = @@ -113,3 +114,6 @@ instance Default Bool where def = False deriving newtype instance HeapWords (HS.Hash h a) + +deriving newtype instance ToCBOR EpochSize +deriving newtype instance FromCBOR EpochSize \ No newline at end of file diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index d7f59e6cdb..56d6ec27cb 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -14,6 +14,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} module Shelley.Spec.Ledger.Rewards ( desirability, @@ -38,7 +39,6 @@ module Shelley.Spec.Ledger.Rewards memberRew, aggregateRewards, sumRewards, - rewardLL, ) where @@ -54,10 +54,10 @@ import Cardano.Binary import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Era,Crypto) import Cardano.Ledger.Val ((<->)) -import Cardano.Slotting.Slot (EpochSize) +import Cardano.Slotting.Slot (EpochSize(..)) import Control.DeepSeq (NFData) import Control.Provenance (ProvM, modifyM) -import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), (), ( + (Era era,Monad m) => PParams era -> BlocksMade (Crypto era) -> Coin -> @@ -585,13 +585,78 @@ reward delegs (Coin totalStake) asc - slotsPerEpoch = do - let totalBlocks = sum b + slotsPerEpoch = completeM pulser where + totalBlocks = sum b Coin activeStake = fold . unStake $ stake - combine = Map.unionWith Set.union - -- We fold 'action' over the pairs in the poolParams Map to compute a pair of maps. - -- we must use a right associative fold. See comments on foldListM below. - action (hk, pparams) (m1, m2) = do + free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) + pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (RewardProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) + -- The function actionFree (below), is uniquely identified by the value RewardCalc :: RewardCalc + -- in the (MAccum (RewardCalc m era c) ...) instance below. + -- The pulser folds actionFree over the poolParams. In this function we 'complete' the fold in 1 go. + +-- ======================================================== +-- FreeVars is the set of variables needed to compute +-- actionFree, so that it can be made into a serializable +-- Pulsable function. + +data FreeVars era = + FreeVars{ b:: Map (KeyHash 'StakePool (Crypto era)) Natural, + delegs:: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)), + stake:: Stake (Crypto era), + addrsRew :: Set (Credential 'Staking (Crypto era)), + totalStake :: Integer, + activeStake :: Integer, + asc :: ActiveSlotCoeff, + totalBlocks :: Natural, -- + r :: Coin, + pp :: PParams era, + slotsPerEpoch :: EpochSize } + +-- FreeVars is serializable + +instance (Era era) => ToCBOR(FreeVars era) where + toCBOR (FreeVars{b,delegs,stake,addrsRew,totalStake,activeStake,asc,totalBlocks,r,pp,slotsPerEpoch}) = + encode(Rec FreeVars !> toMap b !> toMap delegs !> To stake !> toSet addrsRew + !> To totalStake !> To activeStake !> To asc !> To totalBlocks + !> To r !> To pp !> To slotsPerEpoch) + +instance Era era => FromCBOR(FreeVars era) where + fromCBOR = + decode(RecD FreeVars + FreeVars era + -> RewardAns (Crypto era) + -> PulseItem (Crypto era) + -> ProvM + (RewardProvenance (Crypto era)) + m + (RewardAns (Crypto era)) +actionFree + (FreeVars{b,delegs,stake,addrsRew,totalStake,activeStake,asc,totalBlocks,r,pp,slotsPerEpoch}) + (m1, m2) + (hk, pparams) = do let blocksProduced = Map.lookup hk b actgr@(Stake s) = poolStake hk delegs stake Coin pstake = fold s @@ -606,19 +671,22 @@ reward Nothing -> pure (m1, Map.insert hk ls m2) Just n -> do m <- rewardOnePool pp r n totalBlocks pparams actgr sigma sigmaA (Coin totalStake) addrsRew - pure (combine m m1, Map.insert hk ls m2) - foldListM action (Map.empty, Map.empty) (Map.toList poolParams) - --- | Fold a monadic function 'accum' over a list. It is strict in its accumulating parameter. --- since the order matters in 'aggregate' (used in reward above) we need to use the same --- order as previous revisions. That's why we call foldListM before applying accum. -foldListM :: Monad m => (k -> ans -> m ans) -> ans -> [k] -> m ans -foldListM _accum ans [] = pure ans --- Order matters so we don't use this clause (as it associates to the left) --- foldListM accum ans (k:more) = do { !ans1 <- accum k ans; foldListM accum ans1 more } --- instead we use this one that associates to the right. -foldListM accum ans (k : more) = do ans1 <- foldListM accum ans more; accum k ans1 + pure (Map.unionWith Set.union m m1, Map.insert hk ls m2) + +-- ==================================================== +-- The Unit type uniquely associated with the actionFree function + +data RewardCalc (m:: Type -> Type) era c = RewardCalc +instance (Monad m, c ~ Crypto era) => + MAccum (RewardCalc m era c) + (ProvM (RewardProvenance c) m) + (FreeVars era) + (KeyHash 'StakePool c, PoolParams c) + (RewardAns c) + where maccum RewardCalc = actionFree + +-- ========================================================== -- | Compute the Non-Myopic Pool Stake -- -- This function implements non-myopic stake calculation in section 5.6.2 @@ -671,84 +739,3 @@ nonMyopicMemberRew f = maxPool pp rPot (unStakeShare nm) (unStakeShare s) fHat = floor (p * (fromRational . coinToRational) f) in memberRew (Coin fHat) pool t nm - - --- ========================================== - - -data FreeVars era = - FreeVars{ b:: Map (KeyHash 'StakePool (Crypto era)) Natural, - delegs:: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)), - stake:: Stake (Crypto era), - addrsRew :: Set (Credential 'Staking (Crypto era)), - totalStake :: Integer, - activeStake :: Integer, - asc :: ActiveSlotCoeff, - totalBlocks :: Natural, -- - r :: Coin, - pp :: PParams era, - slotsPerEpoch :: EpochSize } - - -actionFree - :: (Monad m) => - FreeVars era - -> ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))) - , Map (KeyHash 'StakePool (Crypto era)) Likelihood) - -> (KeyHash 'StakePool (Crypto era), PoolParams (Crypto era)) - -> ProvM - (Map - (KeyHash 'StakePool (Crypto era)) - (RewardProvenancePool (Crypto era))) - m - ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))) - , Map (KeyHash 'StakePool (Crypto era)) Likelihood) -actionFree (FreeVars{b,delegs,stake,addrsRew,totalStake,activeStake,asc,totalBlocks,r,pp,slotsPerEpoch}) - (m1, m2) (hk, pparams) = do - let blocksProduced = Map.lookup hk b - actgr@(Stake s) = poolStake hk delegs stake - Coin pstake = fold s - sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake - sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake - ls = - likelihood - (fromMaybe 0 blocksProduced) - (leaderProbability asc sigma (_d pp)) - slotsPerEpoch - case blocksProduced of - Nothing -> pure (m1, Map.insert hk ls m2) - Just n -> do - m <- rewardOnePool pp r n totalBlocks pparams actgr sigma sigmaA (Coin totalStake) addrsRew - pure (Map.unionWith Set.union m m1, Map.insert hk ls m2) - -data RewardCalc (m:: Type -> Type) era c = RewardCalc - -instance (Monad m, c ~ Crypto era) => - MAccum (RewardCalc m era c) - (ProvM (Map (KeyHash 'StakePool c) (RewardProvenancePool c)) m) - (FreeVars era) - (KeyHash 'StakePool c, PoolParams c) - ( Map (Credential 'Staking c) (Set (Reward c)), - Map (KeyHash 'StakePool c) Likelihood ) - where maccum RewardCalc = actionFree - --- Make an example LL - -instance Typeable era => ToCBOR (FreeVars era) where - toCBOR _x = undefined - -freevars :: FreeVars era -freevars = undefined - -rewardLL :: (Monad m, Era era) => - LL - (RewardCalc m era (Crypto era)) - (ProvM - (Map - (KeyHash 'StakePool (Crypto era)) - (RewardProvenancePool (Crypto era))) - m) - (Map - (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), - Map (KeyHash 'StakePool (Crypto era)) Likelihood) -rewardLL = LL RewardCalc 10 freevars [] (Map.empty, Map.empty) \ No newline at end of file diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs index 172b83be03..525f8f0af7 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs @@ -381,7 +381,7 @@ rewardsProvenance _ = generate $ do -- Analog to getRewardInfo, but does not produce Provenance justRewardInfo :: - forall era. + forall era. Era era => Globals -> NewEpochState era -> RewardUpdate (Crypto era) @@ -400,14 +400,14 @@ justRewardInfo globals newepochstate = slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals sameWithOrWithoutProvenance :: - forall era. + forall era. Era era => Globals -> NewEpochState era -> Bool sameWithOrWithoutProvenance globals newepochstate = with == without where (with,_) = getRewardInfo globals newepochstate without = justRewardInfo globals newepochstate -nothingInNothingOut :: forall era. NewEpochState era -> Bool +nothingInNothingOut :: forall era. Era era => NewEpochState era -> Bool nothingInNothingOut newepochstate = runReader (preservesNothing $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) @@ -423,7 +423,7 @@ nothingInNothingOut newepochstate = slotsPerEpoch :: EpochSize slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals -justInJustOut :: forall era. NewEpochState era -> Bool +justInJustOut :: forall era. Era era => NewEpochState era -> Bool justInJustOut newepochstate = runReader (preservesJust def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) @@ -639,7 +639,7 @@ createRUpdOld slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) } -oldEqualsNew:: forall era. NewEpochState era -> Bool +oldEqualsNew:: forall era. Era era => NewEpochState era -> Bool oldEqualsNew newepochstate = old == new where globals = testGlobals @@ -655,7 +655,7 @@ oldEqualsNew newepochstate = old == new old = rsOld $ runReader (createRUpdOld slotsPerEpoch blocksmade epochstate maxsupply) globals new = aggregateRewards @era (emptyPParams {_protocolVersion = ProtVer 2 0}) (rs unAggregated) -oldEqualsNewOn:: forall era. NewEpochState era -> Bool +oldEqualsNewOn:: forall era. Era era => NewEpochState era -> Bool oldEqualsNewOn newepochstate = old == new where globals = testGlobals From d4fe53a254a678543f140c25ac2860abaa9af29e Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Fri, 5 Feb 2021 12:39:29 -0800 Subject: [PATCH 05/18] ormolised --- .../src/Shelley/Spec/Ledger/LedgerState.hs | 3 +- .../src/Shelley/Spec/Ledger/Orphans.hs | 7 +- .../src/Shelley/Spec/Ledger/Rewards.hs | 185 ++++++++++-------- 3 files changed, 109 insertions(+), 86 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 3fe98f4884..017053c24c 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -1075,7 +1075,8 @@ updateNonMyopic nm rPot newLikelihoods = -- | Create a reward update createRUpd :: - forall era. Era era => + forall era. + Era era => EpochSize -> BlocksMade (Crypto era) -> EpochState era -> diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs index 04c0224d52..ad53840a9b 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs @@ -5,13 +5,14 @@ module Shelley.Spec.Ledger.Orphans where +import Cardano.Binary (FromCBOR, ToCBOR) import Cardano.Crypto.Hash (Hash (..)) import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Crypto.Hash.Class as HS import Cardano.Crypto.Util (SignableRepresentation (..)) import qualified Cardano.Crypto.Wallet as WC import Cardano.Prelude (HeapWords (..), readEither) -import Cardano.Slotting.Slot (WithOrigin (..), EpochSize(..)) +import Cardano.Slotting.Slot (EpochSize (..), WithOrigin (..)) import Control.DeepSeq (NFData (rnf)) import Data.Aeson import qualified Data.ByteString as Long (ByteString, empty) @@ -27,7 +28,6 @@ import NoThunks.Class (NoThunks (..)) import Shelley.Spec.Ledger.BaseTypes (Network (..), StrictMaybe (..), UnitInterval, interval0) import Shelley.Spec.Ledger.Keys (KeyHash (..)) import Shelley.Spec.Ledger.Slot (BlockNo, EpochNo) -import Cardano.Binary(ToCBOR,FromCBOR) instance FromJSON IPv4 where parseJSON = @@ -116,4 +116,5 @@ instance Default Bool where deriving newtype instance HeapWords (HS.Hash h a) deriving newtype instance ToCBOR EpochSize -deriving newtype instance FromCBOR EpochSize \ No newline at end of file + +deriving newtype instance FromCBOR EpochSize diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index 56d6ec27cb..8afb0446ab 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -2,19 +2,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE StandaloneDeriving #-} module Shelley.Spec.Ledger.Rewards ( desirability, @@ -52,19 +51,21 @@ import Cardano.Binary encodeWord, ) import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era (Era,Crypto) +import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Val ((<->)) -import Cardano.Slotting.Slot (EpochSize(..)) +import Cardano.Slotting.Slot (EpochSize (..)) import Control.DeepSeq (NFData) import Control.Provenance (ProvM, modifyM) -import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), (), ( + (Era era, Monad m) => PParams era -> BlocksMade (Crypto era) -> Coin -> @@ -585,58 +583,76 @@ reward delegs (Coin totalStake) asc - slotsPerEpoch = completeM pulser where - totalBlocks = sum b - Coin activeStake = fold . unStake $ stake - free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) - pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (RewardProvenance (Crypto era)) m) (RewardAns (Crypto era)) - pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) - -- The function actionFree (below), is uniquely identified by the value RewardCalc :: RewardCalc - -- in the (MAccum (RewardCalc m era c) ...) instance below. - -- The pulser folds actionFree over the poolParams. In this function we 'complete' the fold in 1 go. + slotsPerEpoch = completeM pulser + where + totalBlocks = sum b + Coin activeStake = fold . unStake $ stake + free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) + pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (RewardProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) + +-- The function actionFree (below), is uniquely identified by the value RewardCalc :: RewardCalc +-- in the (MAccum (RewardCalc m era c) ...) instance below. +-- The pulser folds actionFree over the poolParams. In this function we 'complete' the fold in 1 go. -- ======================================================== -- FreeVars is the set of variables needed to compute -- actionFree, so that it can be made into a serializable -- Pulsable function. -data FreeVars era = - FreeVars{ b:: Map (KeyHash 'StakePool (Crypto era)) Natural, - delegs:: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)), - stake:: Stake (Crypto era), - addrsRew :: Set (Credential 'Staking (Crypto era)), - totalStake :: Integer, - activeStake :: Integer, - asc :: ActiveSlotCoeff, - totalBlocks :: Natural, -- - r :: Coin, - pp :: PParams era, - slotsPerEpoch :: EpochSize } +data FreeVars era = FreeVars + { b :: Map (KeyHash 'StakePool (Crypto era)) Natural, + delegs :: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)), + stake :: Stake (Crypto era), + addrsRew :: Set (Credential 'Staking (Crypto era)), + totalStake :: Integer, + activeStake :: Integer, + asc :: ActiveSlotCoeff, + totalBlocks :: Natural, -- + r :: Coin, + pp :: PParams era, + slotsPerEpoch :: EpochSize + } -- FreeVars is serializable -instance (Era era) => ToCBOR(FreeVars era) where - toCBOR (FreeVars{b,delegs,stake,addrsRew,totalStake,activeStake,asc,totalBlocks,r,pp,slotsPerEpoch}) = - encode(Rec FreeVars !> toMap b !> toMap delegs !> To stake !> toSet addrsRew - !> To totalStake !> To activeStake !> To asc !> To totalBlocks - !> To r !> To pp !> To slotsPerEpoch) - -instance Era era => FromCBOR(FreeVars era) where +instance (Era era) => ToCBOR (FreeVars era) where + toCBOR (FreeVars {b, delegs, stake, addrsRew, totalStake, activeStake, asc, totalBlocks, r, pp, slotsPerEpoch}) = + encode + ( Rec FreeVars !> toMap b !> toMap delegs !> To stake !> toSet addrsRew + !> To totalStake + !> To activeStake + !> To asc + !> To totalBlocks + !> To r + !> To pp + !> To slotsPerEpoch + ) + +instance Era era => FromCBOR (FreeVars era) where fromCBOR = - decode(RecD FreeVars - FreeVars era - -> RewardAns (Crypto era) - -> PulseItem (Crypto era) - -> ProvM - (RewardProvenance (Crypto era)) - m - (RewardAns (Crypto era)) +actionFree :: + forall m era. + (Monad m) => + FreeVars era -> + RewardAns (Crypto era) -> + PulseItem (Crypto era) -> + ProvM + (RewardProvenance (Crypto era)) + m + (RewardAns (Crypto era)) actionFree - (FreeVars{b,delegs,stake,addrsRew,totalStake,activeStake,asc,totalBlocks,r,pp,slotsPerEpoch}) - (m1, m2) - (hk, pparams) = do - let blocksProduced = Map.lookup hk b - actgr@(Stake s) = poolStake hk delegs stake - Coin pstake = fold s - sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake - sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake - ls = - likelihood - (fromMaybe 0 blocksProduced) - (leaderProbability asc sigma (_d pp)) - slotsPerEpoch - case blocksProduced of - Nothing -> pure (m1, Map.insert hk ls m2) - Just n -> do - m <- rewardOnePool pp r n totalBlocks pparams actgr sigma sigmaA (Coin totalStake) addrsRew - pure (Map.unionWith Set.union m m1, Map.insert hk ls m2) + (FreeVars {b, delegs, stake, addrsRew, totalStake, activeStake, asc, totalBlocks, r, pp, slotsPerEpoch}) + (m1, m2) + (hk, pparams) = do + let blocksProduced = Map.lookup hk b + actgr@(Stake s) = poolStake hk delegs stake + Coin pstake = fold s + sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake + sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake + ls = + likelihood + (fromMaybe 0 blocksProduced) + (leaderProbability asc sigma (_d pp)) + slotsPerEpoch + case blocksProduced of + Nothing -> pure (m1, Map.insert hk ls m2) + Just n -> do + m <- rewardOnePool pp r n totalBlocks pparams actgr sigma sigmaA (Coin totalStake) addrsRew + pure (Map.unionWith Set.union m m1, Map.insert hk ls m2) -- ==================================================== -- The Unit type uniquely associated with the actionFree function -data RewardCalc (m:: Type -> Type) era c = RewardCalc +data RewardCalc (m :: Type -> Type) era c = RewardCalc -instance (Monad m, c ~ Crypto era) => - MAccum (RewardCalc m era c) - (ProvM (RewardProvenance c) m) - (FreeVars era) - (KeyHash 'StakePool c, PoolParams c) - (RewardAns c) - where maccum RewardCalc = actionFree +instance + (Monad m, c ~ Crypto era) => + MAccum + (RewardCalc m era c) + (ProvM (RewardProvenance c) m) + (FreeVars era) + (KeyHash 'StakePool c, PoolParams c) + (RewardAns c) + where + maccum RewardCalc = actionFree -- ========================================================== + -- | Compute the Non-Myopic Pool Stake -- -- This function implements non-myopic stake calculation in section 5.6.2 From a6328e92c7ab7d7377d39441b045df8f16776661 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Mon, 8 Feb 2021 09:41:02 -0800 Subject: [PATCH 06/18] serial --- semantics/executable-spec/src/Data/Pulse.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index b47d5ac4de..1184a4d63a 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -19,7 +19,7 @@ import qualified Data.Map.Strict as Map import Data.Map.Internal (Map (..)) import Control.Monad.Identity(Identity(..)) import Data.Coders -import Cardano.Binary(ToCBOR(..),FromCBOR(..)) +import Cardano.Binary(ToCBOR(..),FromCBOR(..),serialize', decodeFull') import Data.Typeable @@ -342,3 +342,14 @@ instance FromCBOR (LL XXX Identity Int) where foo :: LL XXX Identity Int foo = LL XXX 3 [True] [1,2,3,5,6,7,8] 0 + + +-- ================================= + +serial :: LL XXX Identity Int -> IO(LL XXX Identity Int) +serial x = do + let bytes = serialize' x + putStrLn("Bytes = " ++ show bytes) + case decodeFull' bytes of + Right x -> putStrLn (show x) >> pure x + Left e -> error(show e) \ No newline at end of file From d4c572d60e509505201f39c0518f82bdcbca0a3b Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Mon, 8 Feb 2021 17:09:32 -0800 Subject: [PATCH 07/18] Broke createRupd into 3 phases. --- semantics/executable-spec/src/Data/Pulse.hs | 8 +- .../src/Shelley/Spec/Ledger/API/Wallet.hs | 3 +- .../src/Shelley/Spec/Ledger/LedgerState.hs | 164 +++++++++++------- .../Shelley/Spec/Ledger/RewardProvenance.hs | 12 +- .../src/Shelley/Spec/Ledger/Rewards.hs | 76 ++++++-- .../src/Shelley/Spec/Ledger/STS/Rupd.hs | 7 +- .../test/Test/Shelley/Spec/Ledger/Rewards.hs | 15 +- 7 files changed, 189 insertions(+), 96 deletions(-) diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index 1184a4d63a..9c33693313 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -41,9 +41,9 @@ class Pulsable (pulse :: (Type -> Type) -> Type -> Type) where current :: pulse m ans -> ans pulseM :: Monad m => pulse m ans -> m(pulse m ans) completeM :: Monad m => pulse m ans -> m ans - completeM p = - do p' <- pulseM p - if done p' then pure(current p') else completeM p' + completeM p = if done p + then pure (current p) + else do p' <- pulseM p; completeM p' -- ================================= -- Pulse structure for List in an arbitray monad @@ -351,5 +351,5 @@ serial x = do let bytes = serialize' x putStrLn("Bytes = " ++ show bytes) case decodeFull' bytes of - Right x -> putStrLn (show x) >> pure x + Right x' -> putStrLn (show x') >> pure x' Left e -> error(show e) \ No newline at end of file diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs index b1a5de8c55..edfcff2da5 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs @@ -261,7 +261,7 @@ getRewardInfo :: getRewardInfo globals newepochstate = runReader ( runWithProvM def $ - createRUpd slotsPerEpoch blocksmade epochstate maxsupply + createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc ) globals where @@ -273,3 +273,4 @@ getRewardInfo globals newepochstate = epochnumber = nesEL newepochstate slotsPerEpoch :: EpochSize slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals + asc = activeSlotCoeff globals diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 017053c24c..f2c036cf21 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -72,6 +72,8 @@ module Shelley.Spec.Ledger.LedgerState stakeDistr, applyRUpd, createRUpd, + -- postPulse, + addDesire2, -- NewEpochState (..), getGKeys, @@ -112,8 +114,8 @@ import Cardano.Ledger.Shelley.Constraints import Cardano.Ledger.Val ((<+>), (<->), (<×>)) import qualified Cardano.Ledger.Val as Val import Control.DeepSeq (NFData) -import Control.Monad.Trans.Reader (asks) -import Control.Provenance (ProvM, lift, modifyWithBlackBox, runOtherProv) +-- import Control.Monad.Trans.Reader (asks) +import Control.Provenance (ProvM, modifyWithBlackBox, BlackBox, runOtherProv) import Control.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁)) import Control.State.Transition (STS (State)) import qualified Data.ByteString.Lazy as BSL (length) @@ -141,12 +143,12 @@ import Shelley.Spec.Ledger.Address.Bootstrap verifyBootstrapWit, ) import Shelley.Spec.Ledger.BaseTypes - ( Globals (..), - ShelleyBase, + ( ShelleyBase, StrictMaybe (..), activeSlotVal, intervalValue, unitIntervalToRational, + ActiveSlotCoeff, ) import Shelley.Spec.Ledger.Coin ( Coin (..), @@ -192,6 +194,7 @@ import Shelley.Spec.Ledger.PParams emptyPPPUpdates, ) import Shelley.Spec.Ledger.RewardProvenance (Desirability (..), RewardProvenance (..)) +import qualified Shelley.Spec.Ledger.RewardProvenance as RProv import Shelley.Spec.Ledger.Rewards ( Likelihood (..), NonMyopic (..), @@ -201,8 +204,10 @@ import Shelley.Spec.Ledger.Rewards applyDecay, desirability, percentile', - reward, + -- reward, sumRewards, + RewardCalc(..), + FreeVars(..), ) import Shelley.Spec.Ledger.Serialization (decodeRecordNamed, mapFromCBOR, mapToCBOR) import Shelley.Spec.Ledger.Slot @@ -241,6 +246,7 @@ import Shelley.Spec.Ledger.UTxO txup, verifyWitVKey, ) +import Data.Pulse (LL (..), completeM) -- | Representation of a list of pairs of key pairs, e.g., pay and stake keys type KeyPairs crypto = [(KeyPair 'Payment crypto, KeyPair 'Staking crypto)] @@ -1081,9 +1087,9 @@ createRUpd :: BlocksMade (Crypto era) -> EpochState era -> Coin -> + ActiveSlotCoeff -> ProvM (RewardProvenance (Crypto era)) ShelleyBase (RewardUpdate (Crypto era)) -createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply = do - asc <- lift (asks activeSlotCoeff) +createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ _) maxSupply asc = do let SnapShot stake' delegs' poolParams = _pstakeGo ss Coin reserves = _reserves acnt ds = _dstate $ _delegationState ls @@ -1108,68 +1114,40 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma deltaT1 = floor $ intervalValue (_tau pr) * fromIntegral rPot _R = Coin $ rPot - deltaT1 totalStake = circulation es maxSupply - ((rs_, newLikelihoods), blackBoxPools) <- - runOtherProv - Map.empty - ( reward - pr - b - _R - (Map.keysSet $ _rewards ds) - poolParams - stake' - delegs' - totalStake - asc - slotsPerEpoch - ) - let deltaR2 = _R <-> (sumRewards pr rs_) - -- add under 'key' the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' - addDesire ans key likelihood = case Map.lookup key poolParams of - Nothing -> - -- This case should be unreachable, since a likelihood is calculated - -- for every registered stake pool - Map.insert + -- This initializes the non-aggregates in the provenance data + -- structure. It should be computed lazily, as we might not need it + -- unless we actually compute provenance. + prov = RewardProvenance (unEpochSize slotsPerEpoch) b maxSupply + deltaR1 (Coin 0) _R totalStake blocksMade d expectedBlocks + eta (Coin rPot) (Coin deltaT1) (fold . unStake $ stake') + Map.empty Map.empty +{- + -- A function to compute the 'desirablity' aggregate. Called only if we are computing + -- provenance. Add, under 'key', the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' + addDesire ans key likelihood = + let estimate = (percentile' likelihood) + in Map.insert key ( Desirability { hitRateEstimate = unPerformanceEstimate estimate, - desirabilityScore = 0 - } - ) + desirabilityScore = case Map.lookup key poolParams of + Just pp -> desirability pr (Coin rPot) pp estimate totalStake + Nothing -> 0 }) ans - Just pp -> - Map.insert - key - ( Desirability - { hitRateEstimate = unPerformanceEstimate estimate, - desirabilityScore = - desirability pr (Coin rPot) pp estimate totalStake - } - ) - ans - where - estimate = (percentile' likelihood) - modifyWithBlackBox +-} + free = FreeVars (unBlocksMade b) delegs' stake' (Map.keysSet $ _rewards ds) (unCoin totalStake) + (unCoin (fold . unStake $ stake')) asc (sum (unBlocksMade b)) _R pr slotsPerEpoch + pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) + ((rs_, newLikelihoods), blackBoxPools) <- runOtherProv Map.empty (completeM pulser) + postPulse prov es ((rs_, newLikelihoods), blackBoxPools) +{- + let deltaR2 = _R <-> (sumRewards pr rs_) + modifyWithBlackBox -- Update the aggregates (deltaR2, pools, desirablities) of the provenance blackBoxPools ( \provPools _ -> - RewardProvenance - (unEpochSize slotsPerEpoch) - b - maxSupply - deltaR1 - deltaR2 - _R - totalStake - blocksMade - d - expectedBlocks - eta - (Coin rPot) - (Coin deltaT1) - (fold . unStake $ stake') - provPools - (Map.foldlWithKey' addDesire Map.empty newLikelihoods) - ) + prov { deltaR2 = _R <-> (sumRewards pr rs_), + pools = provPools, + desirabilities = (Map.foldlWithKey' addDesire Map.empty newLikelihoods)}) pure $ RewardUpdate { deltaT = (DeltaCoin deltaT1), @@ -1179,6 +1157,66 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma nonMyopic = (updateNonMyopic nm _R newLikelihoods) } +-} + +postPulse :: Monad m => + RewardProvenance (Crypto era) + -> EpochState era + -> ((Map + (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), + Map (KeyHash 'StakePool (Crypto era)) Likelihood), + Control.Provenance.BlackBox + (Map + (KeyHash 'StakePool (Crypto era)) + (RProv.RewardProvenancePool (Crypto era)))) + -> ProvM + (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) +postPulse (prov@(RewardProvenance{deltaR1 = deltaR1, RProv.r = _r, deltaT1 = (Coin deltaT1)})) + (es@(EpochState{esSnapshots = ss, esPp = pr, esNonMyopic = nm})) + ((rs_, newLikelihoods), blackBoxPools) = do + let deltaR2 = _r <-> (sumRewards pr rs_) + modifyWithBlackBox -- Update the aggregates (deltaR2, pools, desirablities) of the provenance + blackBoxPools + ( \provPools _ -> + prov { deltaR2 = _r <-> (sumRewards pr rs_), + pools = provPools, + desirabilities = (Map.foldlWithKey' (addDesire2 prov es) Map.empty newLikelihoods)}) + pure $ + RewardUpdate + { deltaT = (DeltaCoin deltaT1), + deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2), + rs = rs_, + deltaF = (invert (toDeltaCoin $ _feeSS ss)), + nonMyopic = (updateNonMyopic nm _r newLikelihoods) + } + + +-- A function to compute the 'desirablity' aggregate. Called only if we are computing +-- provenance. Add, under 'key', the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' +addDesire2 :: RewardProvenance crypto + -> EpochState era + -> Map (KeyHash 'StakePool (Crypto era)) Desirability + -> KeyHash 'StakePool (Crypto era) + -> Likelihood + -> Map (KeyHash 'StakePool (Crypto era)) Desirability +addDesire2 (RewardProvenance{RProv.totalStake = totalStake, rPot = rPot}) + (EpochState{esSnapshots = ss, esPp = pr}) + ans key likelihood = + let SnapShot _ _ poolParams = _pstakeGo ss + estimate = (percentile' likelihood) + in Map.insert + key + ( Desirability + { hitRateEstimate = unPerformanceEstimate estimate, + desirabilityScore = case Map.lookup key poolParams of + Just pp -> desirability pr rPot pp estimate totalStake + Nothing -> 0 }) + ans + + + + + -- | Calculate the current circulation -- -- This is used in the rewards calculation, and for API endpoints for pool ranking. diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs index f43827de0a..6e9fc33acf 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs @@ -78,12 +78,17 @@ instance NoThunks Desirability instance NFData Desirability +{- | RewardProvenenace captures some of the intermediate calculations when computimg + the statking reward distribution, most of these fields are simple scalar + values, computed from the current State, and are fixed before we start to compute + the distribution. 3 of them are aggregates computed when we compute the distribution. +-} data RewardProvenance crypto = RewardProvenance { spe :: !Word64, blocks :: !(BlocksMade crypto), maxLL :: !Coin, deltaR1 :: !Coin, - deltaR2 :: !Coin, + deltaR2 :: !Coin, -- Aggregate r :: !Coin, totalStake :: !Coin, blocksCount :: !Integer, @@ -93,12 +98,13 @@ data RewardProvenance crypto = RewardProvenance rPot :: !Coin, deltaT1 :: !Coin, activeStake :: !Coin, - pools :: + pools :: -- Aggregate !( Map (KeyHash 'StakePool crypto) (RewardProvenancePool crypto) ), - desirabilities :: !(Map (KeyHash 'StakePool crypto) Desirability) + desirabilities :: -- Aggregate + !(Map (KeyHash 'StakePool crypto) Desirability) } deriving (Eq, Generic) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index 8afb0446ab..a2d32338de 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -25,6 +25,7 @@ module Shelley.Spec.Ledger.Rewards RewardType (..), Reward (..), reward, + rewardPulser, nonMyopicStake, nonMyopicMemberRew, percentile', @@ -38,6 +39,8 @@ module Shelley.Spec.Ledger.Rewards memberRew, aggregateRewards, sumRewards, + RewardCalc(..), + FreeVars(..), ) where @@ -554,6 +557,23 @@ rewardOnePool lRewardP = lReward } +-- ============================================================================== +-- Type synonyms for the complicated types that make up the reward calculation + +-- | The result of reward calculation is a pair of aggregate Maps. +type RewardAns c = + ( Map (Credential 'Staking c) (Set (Reward c)), + Map (KeyHash 'StakePool c) Likelihood + ) + +-- | We pulse on the list of these pairs +type PulseItem c = (KeyHash 'StakePool c, PoolParams c) + +-- | The provenance we collect +type KeyHashPoolProvenance c = Map (KeyHash 'StakePool c) (RewardProvenancePool c) + +-- =============================================================================== + reward :: forall m era. (Era era, Monad m) => @@ -568,7 +588,7 @@ reward :: ActiveSlotCoeff -> EpochSize -> ProvM - (Map (KeyHash 'StakePool (Crypto era)) (RewardProvenancePool (Crypto era))) + (KeyHashPoolProvenance (Crypto era)) m ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), Map (KeyHash 'StakePool (Crypto era)) Likelihood @@ -588,7 +608,41 @@ reward totalBlocks = sum b Coin activeStake = fold . unStake $ stake free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) - pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (RewardProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) + + + +rewardPulser :: + forall m era. + (Era era, Monad m) => + PParams era -> + BlocksMade (Crypto era) -> + Coin -> + Set (Credential 'Staking (Crypto era)) -> + Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era)) -> + Stake (Crypto era) -> + Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)) -> + Coin -> + ActiveSlotCoeff -> + EpochSize -> + LL (RewardCalc m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) +rewardPulser + pp + (BlocksMade b) + r + addrsRew + poolParams + stake + delegs + (Coin totalStake) + asc + slotsPerEpoch = pulser + where + totalBlocks = sum b + Coin activeStake = fold . unStake $ stake + free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) + pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) -- The function actionFree (below), is uniquely identified by the value RewardCalc :: RewardCalc @@ -642,20 +696,6 @@ instance Era era => FromCBOR (FreeVars era) where PulseItem (Crypto era) -> ProvM - (RewardProvenance (Crypto era)) + (KeyHashPoolProvenance (Crypto era)) m (RewardAns (Crypto era)) actionFree @@ -699,7 +739,7 @@ instance (Monad m, c ~ Crypto era) => MAccum (RewardCalc m era c) - (ProvM (RewardProvenance c) m) + (ProvM (KeyHashPoolProvenance c) m) (FreeVars era) (KeyHash 'StakePool c, PoolParams c) (RewardAns c) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs index dcb0d00c38..8a71b46a1f 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs @@ -31,6 +31,7 @@ import Shelley.Spec.Ledger.BaseTypes epochInfo, maxLovelaceSupply, randomnessStabilisationWindow, + activeSlotCoeff, ) import Shelley.Spec.Ledger.Coin (Coin (..)) import Shelley.Spec.Ledger.EpochBoundary (BlocksMade) @@ -67,14 +68,15 @@ instance (Era era) => STS (RUPD era) where rupdTransition :: Era era => TransitionRule (RUPD era) rupdTransition = do TRC (RupdEnv b es, ru, s) <- judgmentContext - (slotsPerEpoch, slot, maxLL) <- liftSTS $ do + (slotsPerEpoch, slot, maxLL, asc) <- liftSTS $ do ei <- asks epochInfo sr <- asks randomnessStabilisationWindow e <- epochInfoEpoch ei s slotsPerEpoch <- epochInfoSize ei e slot <- epochInfoFirst ei e <&> (+* (Duration sr)) maxLL <- asks maxLovelaceSupply - return (slotsPerEpoch, slot, maxLL) + asc <- asks activeSlotCoeff + return (slotsPerEpoch, slot, maxLL, asc) if s <= slot then pure ru else case ru of @@ -87,5 +89,6 @@ rupdTransition = do b es (Coin (fromIntegral maxLL)) + asc ) SJust _ -> pure ru diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs index 525f8f0af7..0146091ee7 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs @@ -387,7 +387,7 @@ justRewardInfo :: RewardUpdate (Crypto era) justRewardInfo globals newepochstate = runReader - (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) + (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) globals where epochstate = nesEs newepochstate @@ -398,6 +398,7 @@ justRewardInfo globals newepochstate = epochnumber = nesEL newepochstate slotsPerEpoch :: EpochSize slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals + asc = activeSlotCoeff globals sameWithOrWithoutProvenance :: forall era. Era era => @@ -410,7 +411,7 @@ sameWithOrWithoutProvenance globals newepochstate = with == without nothingInNothingOut :: forall era. Era era => NewEpochState era -> Bool nothingInNothingOut newepochstate = runReader - (preservesNothing $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) + (preservesNothing $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) globals where globals = testGlobals @@ -422,11 +423,12 @@ nothingInNothingOut newepochstate = epochnumber = nesEL newepochstate slotsPerEpoch :: EpochSize slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals + asc = activeSlotCoeff globals justInJustOut :: forall era. Era era => NewEpochState era -> Bool justInJustOut newepochstate = runReader - (preservesJust def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) + (preservesJust def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) globals where globals = testGlobals @@ -438,6 +440,7 @@ justInJustOut newepochstate = epochnumber = nesEL newepochstate slotsPerEpoch :: EpochSize slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals + asc = activeSlotCoeff globals -- ==================================================================================== -- To demonstrate that the code we wrote that enables provenance collection does not @@ -651,9 +654,10 @@ oldEqualsNew newepochstate = old == new epochnumber = nesEL newepochstate slotsPerEpoch :: EpochSize slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals - unAggregated = runReader (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) globals + unAggregated = runReader (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) globals old = rsOld $ runReader (createRUpdOld slotsPerEpoch blocksmade epochstate maxsupply) globals new = aggregateRewards @era (emptyPParams {_protocolVersion = ProtVer 2 0}) (rs unAggregated) + asc = activeSlotCoeff globals oldEqualsNewOn:: forall era. Era era => NewEpochState era -> Bool oldEqualsNewOn newepochstate = old == new @@ -667,9 +671,10 @@ oldEqualsNewOn newepochstate = old == new epochnumber = nesEL newepochstate slotsPerEpoch :: EpochSize slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals - (unAggregated,_) = runReader (runWithProvM def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) globals + (unAggregated,_) = runReader (runWithProvM def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) globals old = rsOld $ runReader (createRUpdOld slotsPerEpoch blocksmade epochstate maxsupply) globals new = aggregateRewards @era (emptyPParams {_protocolVersion = ProtVer 2 0}) (rs unAggregated) + asc = activeSlotCoeff globals -- ================================================================== From 1225ae6299cf88bb0eec081800485908a53c316a Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Mon, 8 Feb 2021 19:33:29 -0800 Subject: [PATCH 08/18] ormolise --- .../src/Shelley/Spec/Ledger/LedgerState.hs | 203 +++++++++++------- .../Shelley/Spec/Ledger/RewardProvenance.hs | 17 +- .../src/Shelley/Spec/Ledger/Rewards.hs | 7 +- .../src/Shelley/Spec/Ledger/STS/Rupd.hs | 2 +- 4 files changed, 132 insertions(+), 97 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index f2c036cf21..e9435218a5 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -115,7 +115,7 @@ import Cardano.Ledger.Val ((<+>), (<->), (<×>)) import qualified Cardano.Ledger.Val as Val import Control.DeepSeq (NFData) -- import Control.Monad.Trans.Reader (asks) -import Control.Provenance (ProvM, modifyWithBlackBox, BlackBox, runOtherProv) +import Control.Provenance (BlackBox, ProvM, modifyWithBlackBox, runOtherProv) import Control.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁)) import Control.State.Transition (STS (State)) import qualified Data.ByteString.Lazy as BSL (length) @@ -127,6 +127,9 @@ import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) +-- reward, + +import Data.Pulse (LL (..), completeM) import Data.Ratio ((%)) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) @@ -143,12 +146,12 @@ import Shelley.Spec.Ledger.Address.Bootstrap verifyBootstrapWit, ) import Shelley.Spec.Ledger.BaseTypes - ( ShelleyBase, + ( ActiveSlotCoeff, + ShelleyBase, StrictMaybe (..), activeSlotVal, intervalValue, unitIntervalToRational, - ActiveSlotCoeff, ) import Shelley.Spec.Ledger.Coin ( Coin (..), @@ -196,18 +199,17 @@ import Shelley.Spec.Ledger.PParams import Shelley.Spec.Ledger.RewardProvenance (Desirability (..), RewardProvenance (..)) import qualified Shelley.Spec.Ledger.RewardProvenance as RProv import Shelley.Spec.Ledger.Rewards - ( Likelihood (..), + ( FreeVars (..), + Likelihood (..), NonMyopic (..), PerformanceEstimate (..), Reward (..), + RewardCalc (..), aggregateRewards, applyDecay, desirability, percentile', - -- reward, sumRewards, - RewardCalc(..), - FreeVars(..), ) import Shelley.Spec.Ledger.Serialization (decodeRecordNamed, mapFromCBOR, mapToCBOR) import Shelley.Spec.Ledger.Slot @@ -246,7 +248,6 @@ import Shelley.Spec.Ledger.UTxO txup, verifyWitVKey, ) -import Data.Pulse (LL (..), completeM) -- | Representation of a list of pairs of key pairs, e.g., pay and stake keys type KeyPairs crypto = [(KeyPair 'Payment crypto, KeyPair 'Staking crypto)] @@ -1117,29 +1118,55 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ _) max -- This initializes the non-aggregates in the provenance data -- structure. It should be computed lazily, as we might not need it -- unless we actually compute provenance. - prov = RewardProvenance (unEpochSize slotsPerEpoch) b maxSupply - deltaR1 (Coin 0) _R totalStake blocksMade d expectedBlocks - eta (Coin rPot) (Coin deltaT1) (fold . unStake $ stake') - Map.empty Map.empty -{- - -- A function to compute the 'desirablity' aggregate. Called only if we are computing - -- provenance. Add, under 'key', the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' - addDesire ans key likelihood = - let estimate = (percentile' likelihood) - in Map.insert - key - ( Desirability - { hitRateEstimate = unPerformanceEstimate estimate, - desirabilityScore = case Map.lookup key poolParams of - Just pp -> desirability pr (Coin rPot) pp estimate totalStake - Nothing -> 0 }) - ans --} - free = FreeVars (unBlocksMade b) delegs' stake' (Map.keysSet $ _rewards ds) (unCoin totalStake) - (unCoin (fold . unStake $ stake')) asc (sum (unBlocksMade b)) _R pr slotsPerEpoch + prov = + RewardProvenance + (unEpochSize slotsPerEpoch) + b + maxSupply + deltaR1 + (Coin 0) + _R + totalStake + blocksMade + d + expectedBlocks + eta + (Coin rPot) + (Coin deltaT1) + (fold . unStake $ stake') + Map.empty + Map.empty + {- + -- A function to compute the 'desirablity' aggregate. Called only if we are computing + -- provenance. Add, under 'key', the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' + addDesire ans key likelihood = + let estimate = (percentile' likelihood) + in Map.insert + key + ( Desirability + { hitRateEstimate = unPerformanceEstimate estimate, + desirabilityScore = case Map.lookup key poolParams of + Just pp -> desirability pr (Coin rPot) pp estimate totalStake + Nothing -> 0 }) + ans + -} + free = + FreeVars + (unBlocksMade b) + delegs' + stake' + (Map.keysSet $ _rewards ds) + (unCoin totalStake) + (unCoin (fold . unStake $ stake')) + asc + (sum (unBlocksMade b)) + _R + pr + slotsPerEpoch pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) ((rs_, newLikelihoods), blackBoxPools) <- runOtherProv Map.empty (completeM pulser) postPulse prov es ((rs_, newLikelihoods), blackBoxPools) + {- let deltaR2 = _R <-> (sumRewards pr rs_) modifyWithBlackBox -- Update the aggregates (deltaR2, pools, desirablities) of the provenance @@ -1159,63 +1186,75 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ _) max -} -postPulse :: Monad m => - RewardProvenance (Crypto era) - -> EpochState era - -> ((Map - (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), - Map (KeyHash 'StakePool (Crypto era)) Likelihood), - Control.Provenance.BlackBox - (Map - (KeyHash 'StakePool (Crypto era)) - (RProv.RewardProvenancePool (Crypto era)))) - -> ProvM - (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) -postPulse (prov@(RewardProvenance{deltaR1 = deltaR1, RProv.r = _r, deltaT1 = (Coin deltaT1)})) - (es@(EpochState{esSnapshots = ss, esPp = pr, esNonMyopic = nm})) - ((rs_, newLikelihoods), blackBoxPools) = do - let deltaR2 = _r <-> (sumRewards pr rs_) - modifyWithBlackBox -- Update the aggregates (deltaR2, pools, desirablities) of the provenance - blackBoxPools - ( \provPools _ -> - prov { deltaR2 = _r <-> (sumRewards pr rs_), - pools = provPools, - desirabilities = (Map.foldlWithKey' (addDesire2 prov es) Map.empty newLikelihoods)}) - pure $ - RewardUpdate - { deltaT = (DeltaCoin deltaT1), - deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2), - rs = rs_, - deltaF = (invert (toDeltaCoin $ _feeSS ss)), - nonMyopic = (updateNonMyopic nm _r newLikelihoods) - } - +postPulse :: + Monad m => + RewardProvenance (Crypto era) -> + EpochState era -> + ( ( Map + (Credential 'Staking (Crypto era)) + (Set (Reward (Crypto era))), + Map (KeyHash 'StakePool (Crypto era)) Likelihood + ), + Control.Provenance.BlackBox + ( Map + (KeyHash 'StakePool (Crypto era)) + (RProv.RewardProvenancePool (Crypto era)) + ) + ) -> + ProvM + (RewardProvenance (Crypto era)) + m + (RewardUpdate (Crypto era)) +postPulse + (prov@(RewardProvenance {deltaR1 = deltaR1, RProv.r = _r, deltaT1 = (Coin deltaT1)})) + (es@(EpochState {esSnapshots = ss, esPp = pr, esNonMyopic = nm})) + ((rs_, newLikelihoods), blackBoxPools) = do + let deltaR2 = _r <-> (sumRewards pr rs_) + modifyWithBlackBox -- Update the aggregates (deltaR2, pools, desirablities) of the provenance + blackBoxPools + ( \provPools _ -> + prov + { deltaR2 = _r <-> (sumRewards pr rs_), + pools = provPools, + desirabilities = (Map.foldlWithKey' (addDesire2 prov es) Map.empty newLikelihoods) + } + ) + pure $ + RewardUpdate + { deltaT = (DeltaCoin deltaT1), + deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2), + rs = rs_, + deltaF = (invert (toDeltaCoin $ _feeSS ss)), + nonMyopic = (updateNonMyopic nm _r newLikelihoods) + } -- A function to compute the 'desirablity' aggregate. Called only if we are computing -- provenance. Add, under 'key', the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' -addDesire2 :: RewardProvenance crypto - -> EpochState era - -> Map (KeyHash 'StakePool (Crypto era)) Desirability - -> KeyHash 'StakePool (Crypto era) - -> Likelihood - -> Map (KeyHash 'StakePool (Crypto era)) Desirability -addDesire2 (RewardProvenance{RProv.totalStake = totalStake, rPot = rPot}) - (EpochState{esSnapshots = ss, esPp = pr}) - ans key likelihood = - let SnapShot _ _ poolParams = _pstakeGo ss - estimate = (percentile' likelihood) - in Map.insert - key - ( Desirability - { hitRateEstimate = unPerformanceEstimate estimate, - desirabilityScore = case Map.lookup key poolParams of - Just pp -> desirability pr rPot pp estimate totalStake - Nothing -> 0 }) - ans - - - - +addDesire2 :: + RewardProvenance crypto -> + EpochState era -> + Map (KeyHash 'StakePool (Crypto era)) Desirability -> + KeyHash 'StakePool (Crypto era) -> + Likelihood -> + Map (KeyHash 'StakePool (Crypto era)) Desirability +addDesire2 + (RewardProvenance {RProv.totalStake = totalStake, rPot = rPot}) + (EpochState {esSnapshots = ss, esPp = pr}) + ans + key + likelihood = + let SnapShot _ _ poolParams = _pstakeGo ss + estimate = (percentile' likelihood) + in Map.insert + key + ( Desirability + { hitRateEstimate = unPerformanceEstimate estimate, + desirabilityScore = case Map.lookup key poolParams of + Just pp -> desirability pr rPot pp estimate totalStake + Nothing -> 0 + } + ) + ans -- | Calculate the current circulation -- diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs index 6e9fc33acf..6434410397 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs @@ -78,17 +78,16 @@ instance NoThunks Desirability instance NFData Desirability -{- | RewardProvenenace captures some of the intermediate calculations when computimg - the statking reward distribution, most of these fields are simple scalar - values, computed from the current State, and are fixed before we start to compute - the distribution. 3 of them are aggregates computed when we compute the distribution. --} +-- | RewardProvenenace captures some of the intermediate calculations when computimg +-- the statking reward distribution, most of these fields are simple scalar +-- values, computed from the current State, and are fixed before we start to compute +-- the distribution. 3 of them are aggregates computed when we compute the distribution. data RewardProvenance crypto = RewardProvenance { spe :: !Word64, blocks :: !(BlocksMade crypto), maxLL :: !Coin, deltaR1 :: !Coin, - deltaR2 :: !Coin, -- Aggregate + deltaR2 :: !Coin, -- Aggregate r :: !Coin, totalStake :: !Coin, blocksCount :: !Integer, @@ -98,13 +97,13 @@ data RewardProvenance crypto = RewardProvenance rPot :: !Coin, deltaT1 :: !Coin, activeStake :: !Coin, - pools :: -- Aggregate + pools :: -- Aggregate !( Map (KeyHash 'StakePool crypto) (RewardProvenancePool crypto) ), - desirabilities :: -- Aggregate - !(Map (KeyHash 'StakePool crypto) Desirability) + desirabilities :: -- Aggregate + !(Map (KeyHash 'StakePool crypto) Desirability) } deriving (Eq, Generic) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index a2d32338de..ec1a905261 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -39,8 +39,8 @@ module Shelley.Spec.Ledger.Rewards memberRew, aggregateRewards, sumRewards, - RewardCalc(..), - FreeVars(..), + RewardCalc (..), + FreeVars (..), ) where @@ -611,8 +611,6 @@ reward pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) - - rewardPulser :: forall m era. (Era era, Monad m) => @@ -696,7 +694,6 @@ instance Era era => FromCBOR (FreeVars era) where Date: Tue, 9 Feb 2021 08:21:43 -0800 Subject: [PATCH 09/18] Added extra asc (ActiveSlotCoeff) arg to createRupd in Benchmarks --- .../bench/Shelley/Spec/Ledger/Bench/Rewards.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs index 8770f6db8b..51e8e207d4 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs @@ -30,7 +30,7 @@ import Shelley.Spec.Ledger.Address mkRwdAcnt, ) import Shelley.Spec.Ledger.BaseTypes - ( Globals (epochInfo), + ( Globals (epochInfo,activeSlotCoeff), Network (Testnet), StrictMaybe (..), truncateUnitInterval, @@ -177,7 +177,7 @@ createRUpd :: createRUpd globals cs = runIdentity $ runReaderT - (runProvM (LS.createRUpd epochSize bm es total)) + (runProvM (LS.createRUpd epochSize bm es total asc)) globals where nes = chainNes cs @@ -187,6 +187,7 @@ createRUpd globals cs = epochSize = runIdentity $ epochInfoSize (epochInfo globals) (LS.nesEL nes) + asc = activeSlotCoeff globals -- | Benchmark creating a reward update. @@ -197,7 +198,7 @@ createRUpdWithProv :: createRUpdWithProv globals cs = runIdentity $ runReaderT - (runWithProvM def (LS.createRUpd epochSize bm es total)) + (runWithProvM def (LS.createRUpd epochSize bm es total asc)) globals where nes = chainNes cs @@ -207,3 +208,4 @@ createRUpdWithProv globals cs = epochSize = runIdentity $ epochInfoSize (epochInfo globals) (LS.nesEL nes) + asc = activeSlotCoeff globals From 73dc81209bffb8665b2ec6fe2fc0e794b7c45cb2 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Tue, 9 Feb 2021 15:41:54 -0800 Subject: [PATCH 10/18] completed breaking createRupd into 3 phases. --- .../executable-spec/src/Control/Provenance.hs | 10 + .../src/Shelley/Spec/Ledger/LedgerState.hs | 206 ++++++++++-------- .../src/Shelley/Spec/Ledger/Rewards.hs | 2 + 3 files changed, 133 insertions(+), 85 deletions(-) diff --git a/semantics/executable-spec/src/Control/Provenance.hs b/semantics/executable-spec/src/Control/Provenance.hs index 18fb3f5ebe..877b9f9315 100644 --- a/semantics/executable-spec/src/Control/Provenance.hs +++ b/semantics/executable-spec/src/Control/Provenance.hs @@ -31,6 +31,7 @@ module Control.Provenance runProv, runWithProv, runOtherProv, + liftProv, dump, -- * Operations in Prov instantiation @@ -182,6 +183,15 @@ runOtherProv initial other = do {-# INLINE runOtherProv #-} +-- | lift a provenenace computation from one provenance type (s1) to another (s2) +liftProv :: Monad m => ProvM s1 m a -> s1 -> (a -> s1 -> s2 -> s2) -> ProvM s2 m a +liftProv computation inits1 combine = + do (a,blackbox) <- runOtherProv inits1 computation + modifyWithBlackBox blackbox (combine a) + pure a +{-# INLINE liftProv #-} + + -- ======================================================================= {- | A special case of the ProvM Monad, where the state type is Store a (Map Text PObject), where PObject is a dynamically typed value. This diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index e9435218a5..5a10558d56 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -72,8 +72,8 @@ module Shelley.Spec.Ledger.LedgerState stakeDistr, applyRUpd, createRUpd, - -- postPulse, - addDesire2, + completeRupd, + rupdParameters, -- NewEpochState (..), getGKeys, @@ -115,10 +115,13 @@ import Cardano.Ledger.Val ((<+>), (<->), (<×>)) import qualified Cardano.Ledger.Val as Val import Control.DeepSeq (NFData) -- import Control.Monad.Trans.Reader (asks) -import Control.Provenance (BlackBox, ProvM, modifyWithBlackBox, runOtherProv) +import Control.Provenance (ProvM, liftProv) import Control.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁)) import Control.State.Transition (STS (State)) import qualified Data.ByteString.Lazy as BSL (length) +-- reward, + +import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), ( ToCBOR (RewardSnapShot era) where + toCBOR (RewardSnapShot ss pp nm) = encode (Rec RewardSnapShot !> To ss !> To pp !> To nm) + +instance Era era => FromCBOR (RewardSnapShot era) where + fromCBOR = decode (RecD RewardSnapShot @@ -1080,17 +1098,52 @@ updateNonMyopic nm rPot newLikelihoods = <> newPerf updatedLikelihoods = Map.mapWithKey performance newLikelihoods --- | Create a reward update -createRUpd :: - forall era. - Era era => +-- ==================================================================== +-- Some type synonyms, and generic lifting functions to lift one provenance +-- computation into another, and one to lift a Pulser from one provenance +-- type to another. Then a specialisation of on the Provenance types we +-- use here. + +type RewardPulser m era = + LL + (RewardCalc m era (Crypto era)) + (ProvM (KeyHashPoolProvenance (Crypto era)) m) + (RewardAns (Crypto era)) + +-- | Lift a Pulser in the ProvM monad, from one type of provenance (s1) to another (s2) +pulseProvM :: + (Monad m, Pulsable pulse) => + s1 -> + (s1 -> s2 -> s2) -> + pulse (ProvM s1 m) ans -> + ProvM s2 m (pulse (ProvM s1 m) ans) +pulseProvM initial combine tma = liftProv (pulseM tma) initial (\_ s1 s2 -> combine s1 s2) + +-- | lift a pulseM function from (KeyHashPoolProvenance (Crypto era)) +-- provenance to (RewardProvenance (Crypto er)) provenance +pulseOther :: Monad m => RewardPulser m era -> ProvM (RewardProvenance (Crypto era)) m (RewardPulser m era) +pulseOther tma = pulseProvM Map.empty incrementProvenance tma + +-- | How to merge KeyHashPoolProvenance into RewardProvenance +incrementProvenance :: (KeyHashPoolProvenance crypto) -> RewardProvenance crypto -> RewardProvenance crypto +incrementProvenance provpools (prov@(RewardProvenance {pools = old})) = prov {pools = Map.union provpools old} + +-- ============================= +-- Phase 1 of a reward upate is a pure computation, computing some +-- parameters which become fixed at the time when we reach the stability point. +-- One of these pure results is a Pulser, i.e. a computation that when pulseM'ed +-- computes a portion of what is required, so that it can be spread out in time. + +rupdParameters :: + forall era m. + (Monad m, Era era) => EpochSize -> BlocksMade (Crypto era) -> EpochState era -> Coin -> ActiveSlotCoeff -> - ProvM (RewardProvenance (Crypto era)) ShelleyBase (RewardUpdate (Crypto era)) -createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ _) maxSupply asc = do + (RewardProvenance (Crypto era), RewardSnapShot era, RewardPulser m era) +rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply asc = let SnapShot stake' delegs' poolParams = _pstakeGo ss Coin reserves = _reserves acnt ds = _dstate $ _delegationState ls @@ -1117,8 +1170,10 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ _) max totalStake = circulation es maxSupply -- This initializes the non-aggregates in the provenance data -- structure. It should be computed lazily, as we might not need it - -- unless we actually compute provenance. - prov = + -- unless we actually compute provenance. Note the aggregates ((Coin 0) + -- the two Map.empty's) are expected to be over written, if and + -- when we need provenance. + initprov = RewardProvenance (unEpochSize slotsPerEpoch) b @@ -1136,20 +1191,7 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ _) max (fold . unStake $ stake') Map.empty Map.empty - {- - -- A function to compute the 'desirablity' aggregate. Called only if we are computing - -- provenance. Add, under 'key', the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' - addDesire ans key likelihood = - let estimate = (percentile' likelihood) - in Map.insert - key - ( Desirability - { hitRateEstimate = unPerformanceEstimate estimate, - desirabilityScore = case Map.lookup key poolParams of - Just pp -> desirability pr (Coin rPot) pp estimate totalStake - Nothing -> 0 }) - ans - -} + rewsnap = RewardSnapShot {rewSnapshots = ss, rewPp = pr, rewNonMyopic = nm} free = FreeVars (unBlocksMade b) @@ -1163,62 +1205,35 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ _) max _R pr slotsPerEpoch + pulser :: RewardPulser m era pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) - ((rs_, newLikelihoods), blackBoxPools) <- runOtherProv Map.empty (completeM pulser) - postPulse prov es ((rs_, newLikelihoods), blackBoxPools) - -{- - let deltaR2 = _R <-> (sumRewards pr rs_) - modifyWithBlackBox -- Update the aggregates (deltaR2, pools, desirablities) of the provenance - blackBoxPools - ( \provPools _ -> - prov { deltaR2 = _R <-> (sumRewards pr rs_), - pools = provPools, - desirabilities = (Map.foldlWithKey' addDesire Map.empty newLikelihoods)}) - pure $ - RewardUpdate - { deltaT = (DeltaCoin deltaT1), - deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2), - rs = rs_, - deltaF = (invert (toDeltaCoin $ _feeSS ss)), - nonMyopic = (updateNonMyopic nm _R newLikelihoods) - } - --} - -postPulse :: + in (initprov, rewsnap, pulser) + +-- | Phase 3 of reward update has several parts +-- a) completeM the pulser (in case there are still computions to run) +-- b) Combine the pulser provenance with the RewardProvenance +-- c) Construct the final RewardUpdate +completeRupd :: Monad m => RewardProvenance (Crypto era) -> - EpochState era -> - ( ( Map - (Credential 'Staking (Crypto era)) - (Set (Reward (Crypto era))), - Map (KeyHash 'StakePool (Crypto era)) Likelihood - ), - Control.Provenance.BlackBox - ( Map - (KeyHash 'StakePool (Crypto era)) - (RProv.RewardProvenancePool (Crypto era)) - ) - ) -> - ProvM - (RewardProvenance (Crypto era)) - m - (RewardUpdate (Crypto era)) -postPulse + RewardSnapShot era -> + LL + name + (ProvM (KeyHashPoolProvenance (Crypto era)) m) + (RewardAns (Crypto era)) -> + ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) +completeRupd (prov@(RewardProvenance {deltaR1 = deltaR1, RProv.r = _r, deltaT1 = (Coin deltaT1)})) - (es@(EpochState {esSnapshots = ss, esPp = pr, esNonMyopic = nm})) - ((rs_, newLikelihoods), blackBoxPools) = do - let deltaR2 = _r <-> (sumRewards pr rs_) - modifyWithBlackBox -- Update the aggregates (deltaR2, pools, desirablities) of the provenance - blackBoxPools - ( \provPools _ -> - prov - { deltaR2 = _r <-> (sumRewards pr rs_), - pools = provPools, - desirabilities = (Map.foldlWithKey' (addDesire2 prov es) Map.empty newLikelihoods) + (rewsnap@(RewardSnapShot {rewSnapshots = ss, rewPp = pr, rewNonMyopic = nm})) + (pulser@(LL _ _ _ _ _)) = do + let combine (rs, likely) provPools (rewprov@RewardProvenance {pools = old}) = + rewprov + { deltaR2 = _r <-> (sumRewards pr rs), + pools = Map.union provPools old, + desirabilities = (Map.foldlWithKey' (addDesire prov rewsnap) Map.empty likely) } - ) + (rs_, newLikelihoods) <- liftProv (completeM pulser) Map.empty combine + let deltaR2 = _r <-> (sumRewards pr rs_) pure $ RewardUpdate { deltaT = (DeltaCoin deltaT1), @@ -1228,18 +1243,39 @@ postPulse nonMyopic = (updateNonMyopic nm _r newLikelihoods) } +-- | To create a reward update, run all 3 phases +createRUpd :: + forall era m. + (Monad m, Era era) => + EpochSize -> + BlocksMade (Crypto era) -> + EpochState era -> + Coin -> + ActiveSlotCoeff -> + ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) +createRUpd slotsPerEpoch blocksmade epstate maxSupply asc = do + -- Phase 1, compute parameters + let (prov, rewsnap, pulser) = rupdParameters slotsPerEpoch blocksmade epstate maxSupply asc + + -- Phase 2, pulse 0 or more times + pulser1 <- pulseOther pulser + pulser2 <- pulseOther pulser1 + + -- Phase3 Complete the computation + completeRupd prov rewsnap pulser2 + -- A function to compute the 'desirablity' aggregate. Called only if we are computing --- provenance. Add, under 'key', the pair (LikeliHoodEstimate,Desirability) to the Map 'ans' -addDesire2 :: +-- provenance. Adds nested pair ('key',(LikeliHoodEstimate,Desirability)) to the Map 'ans' +addDesire :: RewardProvenance crypto -> - EpochState era -> + RewardSnapShot era -> Map (KeyHash 'StakePool (Crypto era)) Desirability -> KeyHash 'StakePool (Crypto era) -> Likelihood -> Map (KeyHash 'StakePool (Crypto era)) Desirability -addDesire2 +addDesire (RewardProvenance {RProv.totalStake = totalStake, rPot = rPot}) - (EpochState {esSnapshots = ss, esPp = pr}) + (RewardSnapShot {rewSnapshots = ss, rewPp = pr}) ans key likelihood = diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index ec1a905261..0c9abff80e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -41,6 +41,8 @@ module Shelley.Spec.Ledger.Rewards sumRewards, RewardCalc (..), FreeVars (..), + KeyHashPoolProvenance, + RewardAns, ) where From 54f77b0fd13b9cd01020ead78956a627527dbbd5 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Wed, 10 Feb 2021 11:55:48 -0800 Subject: [PATCH 11/18] Added Data.Closure, serializable functions. --- semantics/executable-spec/small-steps.cabal | 1 + semantics/executable-spec/src/Data/Closure.hs | 118 +++++++++ semantics/executable-spec/src/Data/Pulse.hs | 237 ++++-------------- 3 files changed, 164 insertions(+), 192 deletions(-) create mode 100644 semantics/executable-spec/src/Data/Closure.hs diff --git a/semantics/executable-spec/small-steps.cabal b/semantics/executable-spec/small-steps.cabal index 1d15c6fdea..f32505a159 100644 --- a/semantics/executable-spec/small-steps.cabal +++ b/semantics/executable-spec/small-steps.cabal @@ -35,6 +35,7 @@ library , Data.MemoBytes , Data.Coders , Data.Pulse + , Data.Closure , Control.Provenance , Control.Iterate.SetAlgebra , Control.Iterate.Collect diff --git a/semantics/executable-spec/src/Data/Closure.hs b/semantics/executable-spec/src/Data/Closure.hs new file mode 100644 index 0000000000..186006433b --- /dev/null +++ b/semantics/executable-spec/src/Data/Closure.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} + +-- | Supports the creation of objects with type (Closure name env (a -> b)) which are serializable functions. +module Data.Closure + ( Named(..), + Closure(..), + apply, + rootName, + roundtrip, + ) where + +import Data.Kind(Type) +import Cardano.Binary(ToCBOR(..),FromCBOR(..),serialize', decodeFull') +import Data.Coders +import Data.Typeable(Typeable) + +-- ================================================ + +{- | The type 'name', Names a unique value of type 'v'. Usually 'name' + is a Unit type, An enumeration with one constructor. When this is the + case, it creates a 1-to-1 correspondance between a type and a value, also + a 1-to-1 corresponance between the unique value of type 'name' and the value +-} +class Eq name => Named name v | name -> v where + value :: name -> v + name :: name -> String + +infixl 0 :$ + +-- | A Closure is a serializable function. Apply it using 'apply' +data Closure name (env::[Type]) t where + Close:: Named name (a -> b) => !name -> Closure name '[] (a -> b) + (:$):: !(Closure name env (a -> b)) -> !a -> Closure name (a ': env) b + +-- | Lift a Closure to a real function +apply :: Closure name env (a -> b) -> a -> b +apply (Close nm) a = value nm a +apply (cl :$ x) a = (apply cl x) a + +-- | Get the 'name' value of the underlying function in the closure +rootName :: Closure name env x -> String +rootName (Close nm) = name nm +rootName ( cl :$ _ ) = rootName cl + +-- ===================================================================================== +-- Class instances for Closure come in pairs, +-- one for the empty environment, P(Closure n '[] t), +-- and one for a non-empty environment, P(Closure n (a ': e) (a->b)) + +-- ========== +-- Eq pair + +instance Eq (Closure name '[] x) where + (Close x) == (Close y) = x==y + +instance (Eq a, Eq (Closure name env (a -> x))) => Eq (Closure name (a ': env) x) where + (cl1 :$ x1) == (cl2 :$ x2) = cl1==cl2 && x1 == x2 + +-- =========== +-- Show pair + +instance Show (Closure name '[] x) where + show (Close x) = name x + +instance (Show a, Show (Closure name env (a -> x))) => Show (Closure name (a ': env) x) where + show (cl :$ x) = show cl++" :$ "++show x + +-- ============ +-- ToCBOR pair + +instance (ToCBOR name, Typeable x) => ToCBOR (Closure name '[] x) where + toCBOR (Close nm) = encode(Sum Close 0 !> To nm) + +instance + ( Typeable env, + Typeable name, + Typeable x, + ToCBOR a, + ToCBOR (Closure name env (a -> x)) + ) => ToCBOR (Closure name (a ': env) x) where + toCBOR (cl :$ a) = encode(Sum (:$) 1 !> To cl !> To a) + +-- ============= +-- FromCBOR pair + +instance (Named name (a -> b),Typeable (a->b),FromCBOR name) => FromCBOR (Closure name '[] (a -> b)) where + fromCBOR = decode(Summands "Close" decClose) + where decClose 0 = SumD Close x)) + ) => FromCBOR (Closure name (a ': env) x) where + fromCBOR = decode(Summands ":$" decDollar) + where decDollar 1 = SumD (:$) t -> t +roundtrip t = + case decodeFull' (serialize' t) of + Right x -> x + Left err -> error (show err) diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index 9c33693313..4464b0342b 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -3,12 +3,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StandaloneDeriving #-} - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} module Data.Pulse where @@ -19,8 +19,9 @@ import qualified Data.Map.Strict as Map import Data.Map.Internal (Map (..)) import Control.Monad.Identity(Identity(..)) import Data.Coders -import Cardano.Binary(ToCBOR(..),FromCBOR(..),serialize', decodeFull') +import Cardano.Binary(ToCBOR(..),FromCBOR(..)) import Data.Typeable +import Data.Closure(Closure(..),apply,rootName) -- ==================================================== @@ -157,199 +158,51 @@ foldlWithKeyM' f z = go z !ans2 <- (f ans1 kx x) go ans2 r --- ====================================================== --- Two examples - -isum :: PulseListM Identity Integer -isum = pulseList RightA 10 (+) [1..33] 0 - -{- Note how we start adding the last 10 elements -*Pulse> isum -(Pulse right 10 More 0) -*Pulse> pulse it -(Pulse right 10 More 285) -*Pulse> pulse it -(Pulse right 10 More 470) -*Pulse> pulse it -(Pulse right 10 More 555) -*Pulse> pulse it -(Pulse right 10 Done 561) --} - - -jsum :: PulseListM Identity Integer -jsum = pulseList LeftA 10 (+) [1..33] 0 - -{- Here we are adding the first 10 elements -*Pulse> jsum -(Pulse left 10 More 0) -*Pulse> pulse it -(Pulse left 10 More 55) -*Pulse> pulse it -(Pulse left 10 More 210) -*Pulse> pulse it -(Pulse left 10 More 465) -*Pulse> pulse it -(Pulse left 10 Done 561) --} - -ksum :: PulseList Integer -ksum = pulseList RightA 1 (+) [1..5] 0 -{- -*Pulse> ksum -(Pulse right 1 More 0) -*Pulse> pulse it -(Pulse right 1 More 5) -*Pulse> pulse it -(Pulse right 1 More 9) -*Pulse> pulse it -(Pulse right 1 More 12) -*Pulse> pulse it -(Pulse right 1 More 14) -*Pulse> pulse it -(Pulse right 1 Done 15) --} - -hsum :: PulseList Integer -hsum = pulseList LeftA 1 (+) [1..5] 0 -{- -*Pulse> hsum -(Pulse left 1 More 0) -*Pulse> pulse it -(Pulse left 1 More 1) -*Pulse> pulse it -(Pulse left 1 More 3) -*Pulse> pulse it -(Pulse left 1 More 6) -*Pulse> pulse it -(Pulse left 1 More 10) -*Pulse> pulse it -(Pulse left 1 Done 15) --} - -msum :: PulseMapM Identity (Map Char Integer) -msum = pulseMap 2 - (\ a k n -> Map.insertWith (+) k n a) - (Map.fromList [(c,1) | c <- "abcdefg"]) - (Map.fromList [('z',1),('d',1),('g',1)]) - -{- -Pulse> msum -(Pulse 2 More fromList [('d',1),('g',1),('z',1)]) -*Pulse> pulse it -(Pulse 2 More fromList [('a',1),('b',1),('d',1),('g',1),('z',1)]) -*Pulse> pulse it -(Pulse 2 More fromList [('a',1),('b',1),('c',1),('d',2),('g',1),('z',1)]) -*Pulse> pulse it -(Pulse 2 More fromList [('a',1),('b',1),('c',1),('d',2),('e',1),('f',1),('g',1),('z',1)]) -*Pulse> pulse it -(Pulse 2 Done fromList [('a',1),('b',1),('c',1),('d',2),('e',1),('f',1),('g',2),('z',1)]) --} - - -iosum :: PulseListM IO () -iosum = PulseList LeftA 2 (\ () k -> putStrLn (show k)) [(1::Int)..5] () -{- -*Pulse> iosum -(Pulse left 2 More ()) -*Pulse> pulseM it -1 -2 -(Pulse left 2 More ()) -*Pulse> pulseM it -3 -4 -(Pulse left 2 More ()) -*Pulse> pulseM it -5 -(Pulse left 2 Done ()) --} - -{- -Need to serialize - --} -- ========================================================= --- Every instance of MAccum, refers to exactly one function - -class MAccum unique (m :: Type -> Type) free item ans | unique -> m free item ans where - maccum :: unique -> free -> ans -> item -> m ans --- Here is an example instance +-- | Serializable List based Pulser (SLP) +data SLP name (env::[Type]) i (m :: Type -> Type) ans where + SLP:: !Int -> !(Closure name env (ans -> i -> m ans)) -> ![i] -> !ans -> SLP name env i m ans --- Make a Unique Unit type. (I.e. an enumeration with one constructor) -data XXX = XXX - deriving Show +instance (Show ans, Show i) => Show (SLP name env i m ans) where + show (SLP n cl cs ans) = "(SLP "++show n++" "++rootName cl++status cs++show ans++")" -instance ToCBOR XXX where toCBOR XXX = encode(Rec XXX) -instance FromCBOR XXX where fromCBOR = decode(RecD XXX) +-- we need a pair of Eq instances --- | The unique 'maccum' function of the (MAccum XXX _ _ _ _) instance +instance (Eq ans, Eq i, Eq (Closure name '[] (ans -> i -> m ans))) => Eq (SLP name '[] i m ans) where + (SLP n1 c1 b1 a1) == (SLP n2 c2 b2 a2) = (n1==n2) && (c1==c2) && (b1==b2) && (a1==a2) -fooAccum :: [a] -> Int -> Int -> Identity Int -fooAccum bs ans v = Identity (v+ans + length bs) +instance (Eq ans, Eq i, Eq z, Eq (Closure name (z ': e) (ans -> i -> m ans))) => Eq (SLP name (z ': e) i m ans) where + (SLP n1 c1 b1 a1) == (SLP n2 c2 b2 a2) = (n1==n2) && (c1==c2) && (b1==b2) && (a1==a2) -instance MAccum XXX Identity [Bool] Int Int where - maccum XXX = fooAccum - --- ========================================================= --- LL is a first order data type (no embedded functions) --- that can be given a (Pulsable (LL name)) instance, We --- can also make ToCBOR and FromCBOR instances for it. - -data LL name (m :: Type -> Type) ans where - LL:: (MAccum name m free v ans, ToCBOR v, ToCBOR free) => - name -> !Int -> !free -> ![v] -> !ans -> LL name m ans - -instance (Show ans, Show name) => Show (LL name m ans) where - show (LL name n _ vs ans) = "(LL "++show name++" "++show n++status vs++" "++show ans++")" - - --- There is a single ToCBOR instance for (LL name m ans) --- But because of the uniqueness of the name, which implies --- the hidden types (free and v for LL), We must supply --- a unique FromCBOR instance for each name. See the XXX example below. - -instance (Typeable m, ToCBOR name, ToCBOR ans) => ToCBOR (LL name m ans) where - toCBOR (LL name n free vs ans) = encode(Rec (LL name) !> To n !> To free !> To vs !> To ans) - -instance Pulsable (LL name) where - done (LL _name _n _free zs _ans) = isNil zs - current (LL _ _ _ _ ans) = ans - pulseM (ll@(LL _ _ _ [] _)) = pure ll - pulseM (LL name n free balance ans) = do +instance Pulsable (SLP name env i) where + done (SLP _n _cl zs _ans) = isNil zs + current (SLP _ _ _ ans) = ans + pulseM (ll@(SLP _ _ [] _)) = pure ll + pulseM (SLP n cl balance ans) = do let (steps, balance') = List.splitAt n balance - ans' <- foldlM' (maccum name free) ans steps - pure (LL name n free balance' ans') - completeM (LL name _ free balance ans) = foldlM' (maccum name free) ans balance - --- ================================================= --- To make a serializable type that has a (Pulsable (LL name)) instance, --- first, define a Unit type (an enumeration with 1 constructor). --- This will have a unique MAccum instance, which --- will refer to a unique function with no free variables. --- If we follow the pattern below, then the Pulsable instance --- will refer to that (MAccum) instance, but will store only --- first order data. - --- We must supply a unique FromCBOR instance for each 'name'. The 'name' --- fixes the monad 'm' and 'ans' type, as well as the 'maccum' function --- for XXX at the value level. - -instance FromCBOR (LL XXX Identity Int) where - fromCBOR = decode (RecD (LL XXX) IO(LL XXX Identity Int) -serial x = do - let bytes = serialize' x - putStrLn("Bytes = " ++ show bytes) - case decodeFull' bytes of - Right x' -> putStrLn (show x') >> pure x' - Left e -> error(show e) \ No newline at end of file + ans' <- foldlM' (apply cl) ans steps + pure (SLP n cl balance' ans') + completeM (SLP _ cl balance ans) = foldlM' (apply cl) ans balance + +instance + ( ToCBOR ans, + ToCBOR i, + ToCBOR (Closure name env (ans -> i -> m ans)), + Typeable m, + Typeable name, + Typeable env + ) => ToCBOR (SLP name env i m ans) where + toCBOR (SLP n cl balance ans) = encode (Rec SLP !> To n !> To cl !> To balance !> To ans) + +instance + ( FromCBOR ans, + FromCBOR i, + FromCBOR (Closure name env (ans -> i -> m ans)), + Typeable m, + Typeable name, + Typeable env + ) + => FromCBOR (SLP name env i m ans) where + fromCBOR = decode(RecD SLP Date: Wed, 10 Feb 2021 14:24:09 -0800 Subject: [PATCH 12/18] Added Data.Closure for serializable functions. Redid reward calculation this way. Replaces type LL with SLP (Serializable List based Pulser). --- .../src/Shelley/Spec/Ledger/API/Wallet.hs | 1 - .../src/Shelley/Spec/Ledger/LedgerState.hs | 92 ++++++++----------- .../src/Shelley/Spec/Ledger/Rewards.hs | 74 +++++++++++---- .../test/Test/Shelley/Spec/Ledger/Rewards.hs | 12 +-- 4 files changed, 100 insertions(+), 79 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs index edfcff2da5..3c49e34ed4 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs @@ -254,7 +254,6 @@ getPoolParameters nes poolId = Map.lookup poolId (f nes) getRewardInfo :: forall era. - Era era => Globals -> NewEpochState era -> (RewardUpdate (Crypto era), RewardProvenance (Crypto era)) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 5a10558d56..dfd9589722 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -121,6 +121,7 @@ import Control.State.Transition (STS (State)) import qualified Data.ByteString.Lazy as BSL (length) -- reward, +import Data.Closure (Closure (..)) import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), ( + (Monad m) => EpochSize -> BlocksMade (Crypto era) -> EpochState era -> @@ -1205,8 +1199,8 @@ rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm _R pr slotsPerEpoch - pulser :: RewardPulser m era - pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) + -- pulser :: RewardPulser m era + pulser = SLP 2 (Close RewardStakePool :$ free) (Map.toList poolParams) (Map.empty, Map.empty) in (initprov, rewsnap, pulser) -- | Phase 3 of reward update has several parts @@ -1217,36 +1211,52 @@ completeRupd :: Monad m => RewardProvenance (Crypto era) -> RewardSnapShot era -> - LL - name - (ProvM (KeyHashPoolProvenance (Crypto era)) m) - (RewardAns (Crypto era)) -> + RewardPulser m era -> ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) completeRupd - (prov@(RewardProvenance {deltaR1 = deltaR1, RProv.r = _r, deltaT1 = (Coin deltaT1)})) + (prov@(RewardProvenance {deltaR1 = deltaR1, RProv.r = oldr, deltaT1 = (Coin deltaT1)})) (rewsnap@(RewardSnapShot {rewSnapshots = ss, rewPp = pr, rewNonMyopic = nm})) - (pulser@(LL _ _ _ _ _)) = do + (pulser@(SLP _ _ _ _)) = do let combine (rs, likely) provPools (rewprov@RewardProvenance {pools = old}) = rewprov - { deltaR2 = _r <-> (sumRewards pr rs), + { deltaR2 = oldr <-> (sumRewards pr rs), pools = Map.union provPools old, - desirabilities = (Map.foldlWithKey' (addDesire prov rewsnap) Map.empty likely) + desirabilities = (Map.foldlWithKey' addDesireability Map.empty likely) } + -- A function to compute the 'desirablity' aggregate. Called only if we are computing + -- provenance. Adds nested pair ('key',(LikeliHoodEstimate,Desirability)) to the Map 'ans' + addDesireability ans key likelihood = + let totalstake = (RProv.totalStake prov) + rpot = (RProv.rPot prov) + snaps = (rewSnapshots rewsnap) + protparam = (rewPp rewsnap) + SnapShot _ _ poolParams = _pstakeGo snaps + estimate = (percentile' likelihood) + in Map.insert + key + ( Desirability + { hitRateEstimate = unPerformanceEstimate estimate, + desirabilityScore = case Map.lookup key poolParams of + Just ppx -> desirability protparam rpot ppx estimate totalstake + Nothing -> 0 + } + ) + ans (rs_, newLikelihoods) <- liftProv (completeM pulser) Map.empty combine - let deltaR2 = _r <-> (sumRewards pr rs_) + let deltaR2 = oldr <-> (sumRewards pr rs_) pure $ RewardUpdate { deltaT = (DeltaCoin deltaT1), deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2), rs = rs_, deltaF = (invert (toDeltaCoin $ _feeSS ss)), - nonMyopic = (updateNonMyopic nm _r newLikelihoods) + nonMyopic = (updateNonMyopic nm oldr newLikelihoods) } -- | To create a reward update, run all 3 phases createRUpd :: forall era m. - (Monad m, Era era) => + (Monad m) => EpochSize -> BlocksMade (Crypto era) -> EpochState era -> @@ -1264,34 +1274,6 @@ createRUpd slotsPerEpoch blocksmade epstate maxSupply asc = do -- Phase3 Complete the computation completeRupd prov rewsnap pulser2 --- A function to compute the 'desirablity' aggregate. Called only if we are computing --- provenance. Adds nested pair ('key',(LikeliHoodEstimate,Desirability)) to the Map 'ans' -addDesire :: - RewardProvenance crypto -> - RewardSnapShot era -> - Map (KeyHash 'StakePool (Crypto era)) Desirability -> - KeyHash 'StakePool (Crypto era) -> - Likelihood -> - Map (KeyHash 'StakePool (Crypto era)) Desirability -addDesire - (RewardProvenance {RProv.totalStake = totalStake, rPot = rPot}) - (RewardSnapShot {rewSnapshots = ss, rewPp = pr}) - ans - key - likelihood = - let SnapShot _ _ poolParams = _pstakeGo ss - estimate = (percentile' likelihood) - in Map.insert - key - ( Desirability - { hitRateEstimate = unPerformanceEstimate estimate, - desirabilityScore = case Map.lookup key poolParams of - Just pp -> desirability pr rPot pp estimate totalStake - Nothing -> 0 - } - ) - ans - -- | Calculate the current circulation -- -- This is used in the rewards calculation, and for API endpoints for pool ranking. diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index 0c9abff80e..c3fb5d5787 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -14,6 +14,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Shelley.Spec.Ledger.Rewards ( desirability, @@ -39,10 +40,12 @@ module Shelley.Spec.Ledger.Rewards memberRew, aggregateRewards, sumRewards, - RewardCalc (..), + RewardStakePool (..), FreeVars (..), KeyHashPoolProvenance, RewardAns, + PulseItem, + RewardPulser, ) where @@ -61,6 +64,7 @@ import Cardano.Ledger.Val ((<->)) import Cardano.Slotting.Slot (EpochSize (..)) import Control.DeepSeq (NFData) import Control.Provenance (ProvM, modifyM) +import Data.Closure (Closure (..), Named (..)) import Data.Coders (Decode (..), Encode (..), decode, encode, fromMap, fromSet, toMap, toSet, (!>), ( + (Monad m) => PParams era -> BlocksMade (Crypto era) -> Coin -> @@ -610,12 +625,12 @@ reward totalBlocks = sum b Coin activeStake = fold . unStake $ stake free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) - pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) - pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) + -- pulser :: SLP (RewardStakePool m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser = SLP 2 (Close RewardStakePool :$ free) (Map.toList poolParams) (Map.empty, Map.empty) rewardPulser :: forall m era. - (Era era, Monad m) => + (Monad m) => PParams era -> BlocksMade (Crypto era) -> Coin -> @@ -626,7 +641,7 @@ rewardPulser :: Coin -> ActiveSlotCoeff -> EpochSize -> - LL (RewardCalc m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) + SLP (RewardStakePool m era (Crypto era)) (FreeVars era ': '[]) (PulseItem (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) rewardPulser pp (BlocksMade b) @@ -642,11 +657,12 @@ rewardPulser totalBlocks = sum b Coin activeStake = fold . unStake $ stake free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) - pulser :: LL (RewardCalc m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) - pulser = LL RewardCalc 2 free (Map.toList poolParams) (Map.empty, Map.empty) + closure = (Close RewardStakePool :$ free) + -- pulser :: SLP (RewardStakePool m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser = SLP 2 closure (Map.toList poolParams) (Map.empty, Map.empty) --- The function actionFree (below), is uniquely identified by the value RewardCalc :: RewardCalc --- in the (MAccum (RewardCalc m era c) ...) instance below. +-- The function actionFree (below), is uniquely identified by the value RewardStakePool :: RewardStakePool +-- in the (MAccum (RewardStakePool m era c) ...) instance below. -- The pulser folds actionFree over the poolParams. In this function we 'complete' the fold in 1 go. -- ======================================================== @@ -699,7 +715,7 @@ instance Era era => FromCBOR (FreeVars era) where -- ================================================== -- The function that we call on each pulseM -actionFree :: +rewardStakePool :: forall m era. (Monad m) => FreeVars era -> @@ -709,7 +725,7 @@ actionFree :: (KeyHashPoolProvenance (Crypto era)) m (RewardAns (Crypto era)) -actionFree +rewardStakePool (FreeVars {b, delegs, stake, addrsRew, totalStake, activeStake, asc, totalBlocks, r, pp, slotsPerEpoch}) (m1, m2) (hk, pparams) = do @@ -730,20 +746,44 @@ actionFree pure (Map.unionWith Set.union m m1, Map.insert hk ls m2) -- ==================================================== --- The Unit type uniquely associated with the actionFree function +-- The Unit type uniquely associated with the rewardStakePool function + +data RewardStakePool (m :: Type -> Type) era c = RewardStakePool deriving (Eq, Show) + +instance (Typeable era, Typeable m, Typeable c) => ToCBOR (RewardStakePool m era c) where + toCBOR RewardStakePool = mempty -data RewardCalc (m :: Type -> Type) era c = RewardCalc +instance (Typeable era, Typeable m, Typeable c) => FromCBOR (RewardStakePool m era c) where + fromCBOR = pure RewardStakePool + +instance + (Monad m, c ~ Crypto era) => + Named + (RewardStakePool m era c) + ( FreeVars era -> + RewardAns c -> + PulseItem c -> + ProvM + (KeyHashPoolProvenance c) + m + (RewardAns c) + ) + where + value RewardStakePool = rewardStakePool + name RewardStakePool = "rewardStakePool" +{- instance (Monad m, c ~ Crypto era) => MAccum - (RewardCalc m era c) + (RewardStakePool m era c) (ProvM (KeyHashPoolProvenance c) m) (FreeVars era) (KeyHash 'StakePool c, PoolParams c) (RewardAns c) where - maccum RewardCalc = actionFree + maccum RewardStakePool = rewardStakePool +-} -- ========================================================== diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs index 0146091ee7..1b6a44dae6 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs @@ -381,7 +381,7 @@ rewardsProvenance _ = generate $ do -- Analog to getRewardInfo, but does not produce Provenance justRewardInfo :: - forall era. Era era => + forall era. Globals -> NewEpochState era -> RewardUpdate (Crypto era) @@ -401,14 +401,14 @@ justRewardInfo globals newepochstate = asc = activeSlotCoeff globals sameWithOrWithoutProvenance :: - forall era. Era era => + forall era. Globals -> NewEpochState era -> Bool sameWithOrWithoutProvenance globals newepochstate = with == without where (with,_) = getRewardInfo globals newepochstate without = justRewardInfo globals newepochstate -nothingInNothingOut :: forall era. Era era => NewEpochState era -> Bool +nothingInNothingOut :: forall era. NewEpochState era -> Bool nothingInNothingOut newepochstate = runReader (preservesNothing $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) @@ -425,7 +425,7 @@ nothingInNothingOut newepochstate = slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals asc = activeSlotCoeff globals -justInJustOut :: forall era. Era era => NewEpochState era -> Bool +justInJustOut :: forall era. NewEpochState era -> Bool justInJustOut newepochstate = runReader (preservesJust def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) @@ -642,7 +642,7 @@ createRUpdOld slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) } -oldEqualsNew:: forall era. Era era => NewEpochState era -> Bool +oldEqualsNew:: forall era. NewEpochState era -> Bool oldEqualsNew newepochstate = old == new where globals = testGlobals @@ -659,7 +659,7 @@ oldEqualsNew newepochstate = old == new new = aggregateRewards @era (emptyPParams {_protocolVersion = ProtVer 2 0}) (rs unAggregated) asc = activeSlotCoeff globals -oldEqualsNewOn:: forall era. Era era => NewEpochState era -> Bool +oldEqualsNewOn:: forall era. NewEpochState era -> Bool oldEqualsNewOn newepochstate = old == new where globals = testGlobals From 3c89a900ea111d7ee80ab48acca112a4b70aecc2 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Wed, 10 Feb 2021 20:26:05 -0800 Subject: [PATCH 13/18] Final cleanup, extra stuff to RewardSnapShot, defined PulsState. --- semantics/executable-spec/src/Data/Closure.hs | 15 ++ semantics/executable-spec/src/Data/Pulse.hs | 14 +- .../src/Shelley/Spec/Ledger/BaseTypes.hs | 4 +- .../src/Shelley/Spec/Ledger/LedgerState.hs | 213 ++++++++++-------- .../src/Shelley/Spec/Ledger/Orphans.hs | 2 + .../src/Shelley/Spec/Ledger/Rewards.hs | 59 +++-- 6 files changed, 183 insertions(+), 124 deletions(-) diff --git a/semantics/executable-spec/src/Data/Closure.hs b/semantics/executable-spec/src/Data/Closure.hs index 186006433b..ea1c31b2b1 100644 --- a/semantics/executable-spec/src/Data/Closure.hs +++ b/semantics/executable-spec/src/Data/Closure.hs @@ -8,6 +8,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} -- | Supports the creation of objects with type (Closure name env (a -> b)) which are serializable functions. module Data.Closure @@ -22,6 +24,8 @@ import Data.Kind(Type) import Cardano.Binary(ToCBOR(..),FromCBOR(..),serialize', decodeFull') import Data.Coders import Data.Typeable(Typeable) +import NoThunks.Class(NoThunks,InspectHeapNamed(..)) +import Control.DeepSeq (NFData,rnf) -- ================================================ @@ -41,6 +45,8 @@ data Closure name (env::[Type]) t where Close:: Named name (a -> b) => !name -> Closure name '[] (a -> b) (:$):: !(Closure name env (a -> b)) -> !a -> Closure name (a ': env) b +deriving via InspectHeapNamed "Closure" (Closure name env t) instance NoThunks (Closure name env t) + -- | Lift a Closure to a real function apply :: Closure name env (a -> b) -> a -> b apply (Close nm) a = value nm a @@ -56,6 +62,15 @@ rootName ( cl :$ _ ) = rootName cl -- one for the empty environment, P(Closure n '[] t), -- and one for a non-empty environment, P(Closure n (a ': e) (a->b)) +-- ============ +-- NFData pair + +instance NFData name => NFData (Closure name '[] x) where + rnf (Close x) = rnf x + +instance (NFData a, NFData (Closure name env (a -> x))) => NFData (Closure name (a ': env) x) where + rnf (cl :$ x) = seq (rnf cl) (rnf x) + -- ========== -- Eq pair diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index 4464b0342b..b7f8f012e9 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -9,6 +9,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} module Data.Pulse where @@ -22,6 +24,8 @@ import Data.Coders import Cardano.Binary(ToCBOR(..),FromCBOR(..)) import Data.Typeable import Data.Closure(Closure(..),apply,rootName) +import NoThunks.Class(NoThunks,InspectHeapNamed(..)) +import Control.DeepSeq (NFData,rnf) -- ==================================================== @@ -162,9 +166,17 @@ foldlWithKeyM' f z = go z -- ========================================================= -- | Serializable List based Pulser (SLP) -data SLP name (env::[Type]) i (m :: Type -> Type) ans where +data SLP name env i (m :: Type -> Type) ans where SLP:: !Int -> !(Closure name env (ans -> i -> m ans)) -> ![i] -> !ans -> SLP name env i m ans +deriving via InspectHeapNamed "SLP" (SLP n e i m t) instance NoThunks (SLP n e i m t) + +instance (NFData ans, NFData i, NFData (Closure name '[] (ans -> i -> m ans))) => NFData (SLP name '[] i m ans) where + rnf (SLP n1 c1 b1 a1) = seq (rnf n1) (seq (rnf c1) (seq (rnf b1) (rnf a1))) + +instance (NFData ans, NFData i, NFData (Closure name (z ': e) (ans -> i -> m ans))) => NFData (SLP name (z ': e) i m ans) where + rnf (SLP n1 c1 b1 a1) = seq (rnf n1) (seq (rnf c1) (seq (rnf b1) (rnf a1))) + instance (Show ans, Show i) => Show (SLP name env i m ans) where show (SLP n cl cs ans) = "(SLP "++show n++" "++rootName cl++status cs++show ans++")" diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs index 419c1638d6..d06b8f1801 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs @@ -346,6 +346,8 @@ data ActiveSlotCoeff = ActiveSlotCoeff instance NoThunks ActiveSlotCoeff +instance NFData ActiveSlotCoeff + instance FromCBOR ActiveSlotCoeff where fromCBOR = do v <- fromCBOR @@ -417,7 +419,7 @@ data Globals = Globals -- | The network ID networkId :: !Network } - deriving (Generic) + deriving (Show, Generic) instance NoThunks Globals diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index dfd9589722..e7e7b24d5c 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -41,6 +41,7 @@ module Shelley.Spec.Ledger.LedgerState PState (..), RewardAccounts, RewardUpdate (..), + RewardSnapShot (..), UTxOState (..), depositPoolChange, emptyRewardUpdate, @@ -74,6 +75,7 @@ module Shelley.Spec.Ledger.LedgerState createRUpd, completeRupd, rupdParameters, + pulseOther, -- NewEpochState (..), getGKeys, @@ -114,13 +116,12 @@ import Cardano.Ledger.Shelley.Constraints import Cardano.Ledger.Val ((<+>), (<->), (<×>)) import qualified Cardano.Ledger.Val as Val import Control.DeepSeq (NFData) --- import Control.Monad.Trans.Reader (asks) +-- runProvM) +import Control.Monad.Identity () import Control.Provenance (ProvM, liftProv) import Control.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁)) import Control.State.Transition (STS (State)) import qualified Data.ByteString.Lazy as BSL (length) --- reward, - import Data.Closure (Closure (..)) import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), ( ToCBOR (RewardSnapShot era) where - toCBOR (RewardSnapShot ss pp nm) = encode (Rec RewardSnapShot !> To ss !> To pp !> To nm) - -instance Era era => FromCBOR (RewardSnapShot era) where - fromCBOR = decode (RecD RewardSnapShot RewardUpdate (Crypto era) -> EpochState era -> EpochState era -applyRUpd ru (EpochState as ss ls pr pp _nm) = EpochState as' ss ls' pr pp nm' - where - utxoState_ = _utxoState ls - delegState = _delegationState ls - dState = _dstate delegState - (regRU, unregRU) = - Map.partitionWithKey - (\k _ -> eval (k ∈ dom (_rewards dState))) - (aggregateRewards pr $ rs ru) - as' = - as - { _treasury = (addDeltaCoin (_treasury as) (deltaT ru)) <> fold (range unregRU), - _reserves = addDeltaCoin (_reserves as) (deltaR ru) - } - ls' = - ls - { _utxoState = - utxoState_ {_fees = _fees utxoState_ `addDeltaCoin` deltaF ru}, - _delegationState = - delegState - { _dstate = - dState - { _rewards = eval (_rewards dState ∪+ regRU) - } - } - } - nm' = nonMyopic ru +applyRUpd -- pulsestate + ru + (EpochState as ss ls pr pp _nm) = EpochState as' ss ls' pr pp nm' + where + -- Identity ru = runProvM (completeRupd pulsestate) + utxoState_ = _utxoState ls + delegState = _delegationState ls + dState = _dstate delegState + (regRU, unregRU) = + Map.partitionWithKey + (\k _ -> eval (k ∈ dom (_rewards dState))) + (aggregateRewards pr $ rs ru) + as' = + as + { _treasury = (addDeltaCoin (_treasury as) (deltaT ru)) <> fold (range unregRU), + _reserves = addDeltaCoin (_reserves as) (deltaR ru) + } + ls' = + ls + { _utxoState = + utxoState_ {_fees = _fees utxoState_ `addDeltaCoin` deltaF ru}, + _delegationState = + delegState + { _dstate = + dState + { _rewards = eval (_rewards dState ∪+ regRU) + } + } + } + nm' = nonMyopic ru decayFactor :: Float decayFactor = 0.9 @@ -1099,6 +1091,51 @@ updateNonMyopic nm rPot newLikelihoods = <> newPerf updatedLikelihoods = Map.mapWithKey performance newLikelihoods +-- ========================================= +-- Useful data to pass around interemdate results + +-- | To pulse the reward update, we need a snap shot of the EpochState particular to this computation +data RewardSnapShot era = RewardSnapShot + { rewSnapshots :: !(SnapShots (Crypto era)), + rewPp :: !(PParams era), + rewNonMyopic :: !(NonMyopic (Crypto era)), + rewDeltaR1 :: !Coin, -- deltaR1 + rewR :: !Coin, -- r + rewDeltaT1 :: !Coin, -- deltaT1 + rewTotalStake :: !Coin, -- totalStake + rewRPot :: !Coin -- rPot + } + deriving (Show, Eq, Generic) + +instance NoThunks (RewardSnapShot era) + +instance NFData (RewardSnapShot era) + +instance Era era => ToCBOR (RewardSnapShot era) where + toCBOR (RewardSnapShot ss pp nm dr1 r dt1 tot pot) = + encode + ( Rec RewardSnapShot !> To ss !> To pp !> To nm !> To dr1 + !> To r + !> To dt1 + !> To tot + !> To pot + ) + +instance Era era => FromCBOR (RewardSnapShot era) where + fromCBOR = decode (RecD RewardSnapShot ToCBOR (PulseState m era) where + toCBOR (PulseState s p) = encode (Rec PulseState !> To s !> To p) + +instance (Monad m, Typeable m, Era era) => FromCBOR (PulseState m era) where + fromCBOR = decode (RecD PulseState Coin -> ActiveSlotCoeff -> - (RewardProvenance (Crypto era), RewardSnapShot era, RewardPulser m era) + (PulseState m era) rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply asc = let SnapShot stake' delegs' poolParams = _pstakeGo ss Coin reserves = _reserves acnt @@ -1162,30 +1199,17 @@ rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm deltaT1 = floor $ intervalValue (_tau pr) * fromIntegral rPot _R = Coin $ rPot - deltaT1 totalStake = circulation es maxSupply - -- This initializes the non-aggregates in the provenance data - -- structure. It should be computed lazily, as we might not need it - -- unless we actually compute provenance. Note the aggregates ((Coin 0) - -- the two Map.empty's) are expected to be over written, if and - -- when we need provenance. - initprov = - RewardProvenance - (unEpochSize slotsPerEpoch) - b - maxSupply - deltaR1 - (Coin 0) - _R - totalStake - blocksMade - d - expectedBlocks - eta - (Coin rPot) - (Coin deltaT1) - (fold . unStake $ stake') - Map.empty - Map.empty - rewsnap = RewardSnapShot {rewSnapshots = ss, rewPp = pr, rewNonMyopic = nm} + rewsnap = + RewardSnapShot + { rewSnapshots = ss, + rewPp = pr, + rewNonMyopic = nm, + rewDeltaR1 = deltaR1, + rewR = _R, + rewDeltaT1 = (Coin deltaT1), + rewTotalStake = totalStake, + rewRPot = (Coin rPot) + } free = FreeVars (unBlocksMade b) @@ -1199,9 +1223,9 @@ rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm _R pr slotsPerEpoch - -- pulser :: RewardPulser m era + pulser :: RewardPulser m era pulser = SLP 2 (Close RewardStakePool :$ free) (Map.toList poolParams) (Map.empty, Map.empty) - in (initprov, rewsnap, pulser) + in (PulseState rewsnap pulser) -- | Phase 3 of reward update has several parts -- a) completeM the pulser (in case there are still computions to run) @@ -1209,28 +1233,33 @@ rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm -- c) Construct the final RewardUpdate completeRupd :: Monad m => - RewardProvenance (Crypto era) -> - RewardSnapShot era -> - RewardPulser m era -> + PulseState m era -> ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) completeRupd - (prov@(RewardProvenance {deltaR1 = deltaR1, RProv.r = oldr, deltaT1 = (Coin deltaT1)})) - (rewsnap@(RewardSnapShot {rewSnapshots = ss, rewPp = pr, rewNonMyopic = nm})) - (pulser@(SLP _ _ _ _)) = do + ( PulseState + ( RewardSnapShot + { rewDeltaR1 = deltaR1, + rewR = oldr, + rewDeltaT1 = (Coin deltaT1), + rewNonMyopic = nm, + rewTotalStake = totalstake, + rewRPot = rpot, + rewSnapshots = snaps, + rewPp = protparam + } + ) + pulser + ) = do let combine (rs, likely) provPools (rewprov@RewardProvenance {pools = old}) = rewprov - { deltaR2 = oldr <-> (sumRewards pr rs), + { deltaR2 = oldr <-> (sumRewards protparam rs), pools = Map.union provPools old, desirabilities = (Map.foldlWithKey' addDesireability Map.empty likely) } -- A function to compute the 'desirablity' aggregate. Called only if we are computing -- provenance. Adds nested pair ('key',(LikeliHoodEstimate,Desirability)) to the Map 'ans' addDesireability ans key likelihood = - let totalstake = (RProv.totalStake prov) - rpot = (RProv.rPot prov) - snaps = (rewSnapshots rewsnap) - protparam = (rewPp rewsnap) - SnapShot _ _ poolParams = _pstakeGo snaps + let SnapShot _ _ poolParams = _pstakeGo snaps estimate = (percentile' likelihood) in Map.insert key @@ -1243,13 +1272,13 @@ completeRupd ) ans (rs_, newLikelihoods) <- liftProv (completeM pulser) Map.empty combine - let deltaR2 = oldr <-> (sumRewards pr rs_) + let deltaR2 = oldr <-> (sumRewards protparam rs_) pure $ RewardUpdate { deltaT = (DeltaCoin deltaT1), deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2), rs = rs_, - deltaF = (invert (toDeltaCoin $ _feeSS ss)), + deltaF = (invert (toDeltaCoin $ _feeSS snaps)), nonMyopic = (updateNonMyopic nm oldr newLikelihoods) } @@ -1265,14 +1294,16 @@ createRUpd :: ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) createRUpd slotsPerEpoch blocksmade epstate maxSupply asc = do -- Phase 1, compute parameters - let (prov, rewsnap, pulser) = rupdParameters slotsPerEpoch blocksmade epstate maxSupply asc + let (PulseState rewsnap pulser) = rupdParameters slotsPerEpoch blocksmade epstate maxSupply asc -- Phase 2, pulse 0 or more times pulser1 <- pulseOther pulser pulser2 <- pulseOther pulser1 -- Phase3 Complete the computation - completeRupd prov rewsnap pulser2 + completeRupd (PulseState rewsnap pulser2) + +-- ===================================================================== -- | Calculate the current circulation -- diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs index ad53840a9b..c4ff6357f6 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs @@ -117,4 +117,6 @@ deriving newtype instance HeapWords (HS.Hash h a) deriving newtype instance ToCBOR EpochSize +deriving newtype instance NFData EpochSize + deriving newtype instance FromCBOR EpochSize diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index c3fb5d5787..d71177e353 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -83,7 +83,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) import GHC.Generics (Generic) -import NoThunks.Class (NoThunks (..)) +import NoThunks.Class (InspectHeapNamed (..), NoThunks (..)) import Numeric.Natural (Natural) import Quiet import Shelley.Spec.Ledger.BaseTypes @@ -565,7 +565,7 @@ rewardOnePool } -- ============================================================================== --- Type synonyms for the complicated types that make up the reward calculation +-- Type synonyms for the complicated types that make up the reward calculation with Pulsing -- | The result of reward calculation is a pair of aggregate Maps. type RewardAns c = @@ -610,9 +610,10 @@ reward :: ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), Map (KeyHash 'StakePool (Crypto era)) Likelihood ) -reward - pp - (BlocksMade b) +reward pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch = + completeM (rewardPulser pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch) + +{- r addrsRew poolParams @@ -620,13 +621,14 @@ reward delegs (Coin totalStake) asc - slotsPerEpoch = completeM pulser + slotsPerEpoch where totalBlocks = sum b Coin activeStake = fold . unStake $ stake free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) - -- pulser :: SLP (RewardStakePool m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser :: RewardPulser m era pulser = SLP 2 (Close RewardStakePool :$ free) (Map.toList poolParams) (Map.empty, Map.empty) +-} rewardPulser :: forall m era. @@ -641,7 +643,7 @@ rewardPulser :: Coin -> ActiveSlotCoeff -> EpochSize -> - SLP (RewardStakePool m era (Crypto era)) (FreeVars era ': '[]) (PulseItem (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) + RewardPulser m era rewardPulser pp (BlocksMade b) @@ -658,16 +660,12 @@ rewardPulser Coin activeStake = fold . unStake $ stake free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) closure = (Close RewardStakePool :$ free) - -- pulser :: SLP (RewardStakePool m era (Crypto era)) (ProvM (KeyHashPoolProvenance (Crypto era)) m) (RewardAns (Crypto era)) + pulser :: RewardPulser m era pulser = SLP 2 closure (Map.toList poolParams) (Map.empty, Map.empty) --- The function actionFree (below), is uniquely identified by the value RewardStakePool :: RewardStakePool --- in the (MAccum (RewardStakePool m era c) ...) instance below. --- The pulser folds actionFree over the poolParams. In this function we 'complete' the fold in 1 go. - -- ======================================================== -- FreeVars is the set of variables needed to compute --- actionFree, so that it can be made into a serializable +-- rewardStakePool, so that it can be made into a serializable -- Pulsable function. data FreeVars era = FreeVars @@ -683,8 +681,11 @@ data FreeVars era = FreeVars pp :: PParams era, slotsPerEpoch :: EpochSize } + deriving (Show, Eq, Generic) + +deriving via InspectHeapNamed "FreeVars" (FreeVars era) instance NoThunks (FreeVars era) --- FreeVars is serializable +instance NFData (FreeVars era) instance (Era era) => ToCBOR (FreeVars era) where toCBOR (FreeVars {b, delegs, stake, addrsRew, totalStake, activeStake, asc, totalBlocks, r, pp, slotsPerEpoch}) = @@ -713,8 +714,12 @@ instance Era era => FromCBOR (FreeVars era) where ) -- ================================================== --- The function that we call on each pulseM +-- The function rewardStakePool (below), is uniquely identified by the +-- value RewardStakePool :: (RewardStakePool m era c) +-- in the (Names (RewardStakePool m era c) ...) instance below. +-- The pulser folds rewardStakePool over the poolParams. +-- The function that we call on each pulseM rewardStakePool :: forall m era. (Monad m) => @@ -746,9 +751,13 @@ rewardStakePool pure (Map.unionWith Set.union m m1, Map.insert hk ls m2) -- ==================================================== --- The Unit type uniquely associated with the rewardStakePool function -data RewardStakePool (m :: Type -> Type) era c = RewardStakePool deriving (Eq, Show) +-- | The Unit type uniquely associated with the rewardStakePool function +data RewardStakePool (m :: Type -> Type) era c = RewardStakePool deriving (Eq, Show, Generic) + +instance NoThunks (RewardStakePool m era c) + +instance NFData (RewardStakePool m era c) instance (Typeable era, Typeable m, Typeable c) => ToCBOR (RewardStakePool m era c) where toCBOR RewardStakePool = mempty @@ -756,6 +765,7 @@ instance (Typeable era, Typeable m, Typeable c) => ToCBOR (RewardStakePool m era instance (Typeable era, Typeable m, Typeable c) => FromCBOR (RewardStakePool m era c) where fromCBOR = pure RewardStakePool +-- | The Named instance that associates (RewardStakePool m era c) with the function rewardStakePool instance (Monad m, c ~ Crypto era) => Named @@ -772,19 +782,6 @@ instance value RewardStakePool = rewardStakePool name RewardStakePool = "rewardStakePool" -{- -instance - (Monad m, c ~ Crypto era) => - MAccum - (RewardStakePool m era c) - (ProvM (KeyHashPoolProvenance c) m) - (FreeVars era) - (KeyHash 'StakePool c, PoolParams c) - (RewardAns c) - where - maccum RewardStakePool = rewardStakePool --} - -- ========================================================== -- | Compute the Non-Myopic Pool Stake From d85f6eb3dc395a117c044d9d346cc56cb77b4eda Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Thu, 11 Feb 2021 15:01:33 -0800 Subject: [PATCH 14/18] Introduced PulsingRewUpdate as a 3 constructor state: Waiting Pulsing Complete. Made that the State in the RUpd rule. Introduced 3 operations startStep pulseStep completStep, used them to update the rule. Fixed dependencies in all places in Shelley era (tests included). Some tests fail. But making everything go in 1 rule succeeds. liftSTS $ runProvM $ Complete <$> createRUpd slotsPerEpoch b es maxsupply asc Must be something about cycling through the blocks I am not getting. --- semantics/executable-spec/src/Data/Closure.hs | 7 +- .../Spec/Ledger/API/ByronTranslation.hs | 3 +- .../src/Shelley/Spec/Ledger/LedgerState.hs | 96 +++++++++++++------ .../src/Shelley/Spec/Ledger/STS/Chain.hs | 4 +- .../src/Shelley/Spec/Ledger/STS/NewEpoch.hs | 9 +- .../src/Shelley/Spec/Ledger/STS/Rupd.hs | 65 ++++++++++++- .../src/Shelley/Spec/Ledger/STS/Tick.hs | 18 +--- .../Serialisation/EraIndepGenerators.hs | 7 +- .../Spec/Ledger/Examples/Combinators.hs | 7 +- .../Ledger/Serialisation/Golden/Encoding.hs | 6 +- 10 files changed, 163 insertions(+), 59 deletions(-) diff --git a/semantics/executable-spec/src/Data/Closure.hs b/semantics/executable-spec/src/Data/Closure.hs index ea1c31b2b1..2fe03d7dbd 100644 --- a/semantics/executable-spec/src/Data/Closure.hs +++ b/semantics/executable-spec/src/Data/Closure.hs @@ -59,8 +59,11 @@ rootName ( cl :$ _ ) = rootName cl -- ===================================================================================== -- Class instances for Closure come in pairs, --- one for the empty environment, P(Closure n '[] t), --- and one for a non-empty environment, P(Closure n (a ': e) (a->b)) +-- one for the empty environment: P(Closure n '[] t), +-- and one for a non-empty environment: P(Closure n (a ': e) t). +-- The instance for the non-empty case always has the inductive structure: +-- (P a, P (Closure name env (a -> x))) => P (Closure name (a ': env) x) . +-- Note how the 'env' gets smaller in the inductive case: env < (a ': env) . -- ============ -- NFData pair diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs index fe580f9690..3920d1c590 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs @@ -32,6 +32,7 @@ import Shelley.Spec.Ledger.API.Types import Shelley.Spec.Ledger.Coin (CompactForm (CompactCoin)) import Shelley.Spec.Ledger.CompactAddr (CompactAddr (UnsafeCompactAddr)) import Shelley.Spec.Ledger.EpochBoundary +import Shelley.Spec.Ledger.LedgerState (PulsingRewUpdate (Waiting)) import Shelley.Spec.Ledger.STS.Chain (pparamsToChainChecksData) import Shelley.Spec.Ledger.Slot @@ -98,7 +99,7 @@ translateToShelleyLedgerState genesisShelley epochNo cvs = nesBprev = BlocksMade Map.empty, nesBcur = BlocksMade Map.empty, nesEs = epochState, - nesRu = SNothing, + nesRu = Waiting, nesPd = PoolDistr Map.empty } where diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index e7e7b24d5c..922b3d7382 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -11,6 +11,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -32,6 +33,7 @@ module Shelley.Spec.Ledger.LedgerState DState (..), EpochState (..), UpecState (..), + PulsingRewUpdate (..), FutureGenDeleg (..), InstantaneousRewards (..), Ix, @@ -74,7 +76,9 @@ module Shelley.Spec.Ledger.LedgerState applyRUpd, createRUpd, completeRupd, - rupdParameters, + startStep, + pulseStep, + completeStep, pulseOther, -- NewEpochState (..), @@ -150,12 +154,12 @@ import Shelley.Spec.Ledger.Address.Bootstrap ) import Shelley.Spec.Ledger.BaseTypes ( ActiveSlotCoeff, + ShelleyBase, + -- Globals, StrictMaybe (..), activeSlotVal, intervalValue, unitIntervalToRational, - -- ShelleyBase, - -- Globals, ) import Shelley.Spec.Ledger.Coin ( Coin (..), @@ -620,9 +624,8 @@ data NewEpochState era = NewEpochState -- | Epoch state before current nesEs :: !(EpochState era), -- | Possible reward update - nesRu :: !(StrictMaybe (RewardUpdate (Crypto era))), - -- nesRu :: !(StrictMaybe (PulseState ShelleyBase era)), - + -- nesRu :: !(StrictMaybe (RewardUpdate (Crypto era))), + nesRu :: !(PulsingRewUpdate ShelleyBase era), -- | Stake distribution within the stake pool nesPd :: !(PoolDistr (Crypto era)) } @@ -1034,7 +1037,7 @@ stakeDistr u ds ps = -- | Apply a reward update applyRUpd :: - -- PulseState ShelleyBase era -> + -- PulsingRewUpdate ShelleyBase era -> RewardUpdate (Crypto era) -> EpochState era -> EpochState era @@ -1125,16 +1128,26 @@ instance Era era => FromCBOR (RewardSnapShot era) where fromCBOR = decode (RecD RewardSnapShot ToCBOR (PulseState m era) where - toCBOR (PulseState s p) = encode (Rec PulseState !> To s !> To p) +instance (Typeable m, Era era) => ToCBOR (PulsingRewUpdate m era) where + toCBOR Waiting = encode (Sum Waiting 0) + toCBOR (Pulsing s p) = encode (Sum Pulsing 1 !> To s !> To p) + toCBOR (Complete r) = encode (Sum (Complete @m @era) 2 !> To r) -instance (Monad m, Typeable m, Era era) => FromCBOR (PulseState m era) where - fromCBOR = decode (RecD PulseState FromCBOR (PulsingRewUpdate m era) where + fromCBOR = decode (Summands "PulsingRewUpdate" decPS) + where + decPS 0 = (SumD Waiting) + decPS 1 = (SumD Pulsing EpochSize -> @@ -1173,8 +1186,8 @@ rupdParameters :: EpochState era -> Coin -> ActiveSlotCoeff -> - (PulseState m era) -rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply asc = + (PulsingRewUpdate m era) +startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply asc = let SnapShot stake' delegs' poolParams = _pstakeGo ss Coin reserves = _reserves acnt ds = _dstate $ _delegationState ls @@ -1225,7 +1238,32 @@ rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm slotsPerEpoch pulser :: RewardPulser m era pulser = SLP 2 (Close RewardStakePool :$ free) (Map.toList poolParams) (Map.empty, Map.empty) - in (PulseState rewsnap pulser) + in (Pulsing rewsnap pulser) + +-- Phase 2 + +pulseStep :: + Monad m => + PulsingRewUpdate m era -> + ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era) +pulseStep Waiting = pure Waiting +pulseStep (Complete r) = pure (Complete r) +pulseStep (p@(Pulsing _ pulser)) | done pulser = completeStep p +pulseStep (Pulsing rewsnap pulser) = do + p2 <- (pulseOther pulser) + pure (Pulsing rewsnap p2) + +-- Phase 3 + +completeStep :: + Monad m => + PulsingRewUpdate m era -> + ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era) +completeStep Waiting = error ("Can't complete a Waiting step") +completeStep (Complete r) = pure (Complete r) +completeStep (Pulsing rewsnap pulser) = do + p2 <- completeRupd (Pulsing rewsnap pulser) + pure (Complete p2) -- | Phase 3 of reward update has several parts -- a) completeM the pulser (in case there are still computions to run) @@ -1233,10 +1271,12 @@ rupdParameters slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm -- c) Construct the final RewardUpdate completeRupd :: Monad m => - PulseState m era -> + PulsingRewUpdate m era -> ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) +completeRupd Waiting = error "Tried to complete a Waiting PulsingRewUpdate, this should be unreachable." +completeRupd (Complete x) = pure x completeRupd - ( PulseState + ( Pulsing ( RewardSnapShot { rewDeltaR1 = deltaR1, rewR = oldr, @@ -1293,15 +1333,15 @@ createRUpd :: ActiveSlotCoeff -> ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) createRUpd slotsPerEpoch blocksmade epstate maxSupply asc = do - -- Phase 1, compute parameters - let (PulseState rewsnap pulser) = rupdParameters slotsPerEpoch blocksmade epstate maxSupply asc - - -- Phase 2, pulse 0 or more times - pulser1 <- pulseOther pulser - pulser2 <- pulseOther pulser1 - - -- Phase3 Complete the computation - completeRupd (PulseState rewsnap pulser2) + step1 <- pure $ startStep slotsPerEpoch blocksmade epstate maxSupply asc + step2 <- pulseStep step1 + step3 <- completeStep step2 + case step3 of + Complete rewupdate -> pure rewupdate + Waiting -> error "Wait never returned by completeStep" + Pulsing _ _ -> error "Pulsing never returned by completeStep" + +-- completeStep $ startStep slotsPerEpoch b es maxsupply asc -- ===================================================================== diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs index 53aac60135..43a2989c85 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs @@ -60,7 +60,6 @@ import Shelley.Spec.Ledger.BaseTypes ( Globals (..), Nonce (..), ShelleyBase, - StrictMaybe (..), ) import Shelley.Spec.Ledger.BlockChain ( BHeader, @@ -93,6 +92,7 @@ import Shelley.Spec.Ledger.LedgerState LedgerState (..), NewEpochState (..), PState (..), + PulsingRewUpdate (..), TransUTxOState, UTxOState (..), updateNES, @@ -213,7 +213,7 @@ initialShelleyState lab e utxo reserves genDelegs pp initNonce = pp def ) - SNothing + Waiting (PoolDistr Map.empty) ) cs diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs index c9168b9572..281cfa5c65 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs @@ -99,7 +99,7 @@ instance (BlocksMade Map.empty) (BlocksMade Map.empty) def - SNothing + Waiting (PoolDistr Map.empty) ] @@ -128,8 +128,9 @@ newEpochTransition = do then pure src else do es' <- case ru of - SNothing -> pure es - SJust ru' -> do + Waiting -> pure es + Pulsing _ _ -> error "Pulsing state in newEpochTransition" -- TODO What can we do about this? + Complete ru' -> do let RewardUpdate dt dr rs_ df _ = ru' totRs = sumRewards (esPrevPp es) rs_ Val.isZero (dt <> (dr <> (toDeltaCoin totRs) <> df)) ?! CorruptRewardUpdate ru' @@ -145,7 +146,7 @@ newEpochTransition = do bcur (BlocksMade Map.empty) es''' - SNothing + Waiting pd' calculatePoolDistr :: SnapShot crypto -> PoolDistr crypto diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs index 89869acb3a..96f0c372fb 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs @@ -9,10 +9,22 @@ module Shelley.Spec.Ledger.STS.Rupd RupdEnv (..), PredicateFailure, RupdPredicateFailure, + epochInfoRange, + PulsingRewUpdate (..), + startStep, + pulseStep, + completeStep, + lift, + Identity (..), ) where import Cardano.Ledger.Era (Crypto, Era) +-- RewardUpdate, + +import Cardano.Slotting.EpochInfo.API (epochInfoRange) +import Control.Monad.Identity (Identity (..)) +import Control.Monad.Trans (lift) import Control.Monad.Trans.Reader (asks) import Control.Provenance (runProvM) import Control.State.Transition @@ -27,7 +39,6 @@ import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Shelley.Spec.Ledger.BaseTypes ( ShelleyBase, - StrictMaybe (..), activeSlotCoeff, epochInfo, maxLovelaceSupply, @@ -35,7 +46,14 @@ import Shelley.Spec.Ledger.BaseTypes ) import Shelley.Spec.Ledger.Coin (Coin (..)) import Shelley.Spec.Ledger.EpochBoundary (BlocksMade) -import Shelley.Spec.Ledger.LedgerState (EpochState, RewardUpdate, createRUpd) +import Shelley.Spec.Ledger.LedgerState + ( EpochState, + PulsingRewUpdate (..), + completeStep, + createRUpd, + pulseStep, + startStep, + ) import Shelley.Spec.Ledger.Slot ( Duration (..), SlotNo, @@ -55,6 +73,7 @@ data RupdPredicateFailure era -- No predicate failures instance NoThunks (RupdPredicateFailure era) +{- instance (Era era) => STS (RUPD era) where type State (RUPD era) = StrictMaybe (RewardUpdate (Crypto era)) type Signal (RUPD era) = SlotNo @@ -92,3 +111,45 @@ rupdTransition = do asc ) SJust _ -> pure ru +-} + +instance (Era era) => STS (RUPD era) where + type State (RUPD era) = PulsingRewUpdate ShelleyBase era + type Signal (RUPD era) = SlotNo + type Environment (RUPD era) = RupdEnv era + type BaseM (RUPD era) = ShelleyBase + type PredicateFailure (RUPD era) = RupdPredicateFailure era + + initialRules = [pure Waiting] + transitionRules = [rupdTransition] + +rupdTransition :: Era era => TransitionRule (RUPD era) +rupdTransition = do + TRC (RupdEnv b es, ru, s) <- judgmentContext + (slotsPerEpoch, slot, maxLL, asc, lastblock) <- liftSTS $ do + ei <- asks epochInfo + sr <- asks randomnessStabilisationWindow + e <- epochInfoEpoch ei s + slotsPerEpoch <- epochInfoSize ei e + slot <- epochInfoFirst ei e <&> (+* (Duration sr)) + (_first, lastblock) <- lift (epochInfoRange ei e) + maxLL <- asks maxLovelaceSupply + asc <- asks activeSlotCoeff + return (slotsPerEpoch, slot, maxLL, asc, lastblock) + let maxsupply = Coin (fromIntegral maxLL) + case (s <= slot, s == lastblock) of + -- Waiting for the stabiliy point, do nothing, keep waiting + (True, _) -> pure Waiting + (False, _) | ((2 * 2 == 2 + (2 :: Int))) -> liftSTS $ runProvM $ Complete <$> createRUpd slotsPerEpoch b es maxsupply asc + -- We are in the last block, finish everything up + (False, True) -> + case ru of + Waiting -> liftSTS $ runProvM $ completeStep $ startStep slotsPerEpoch b es maxsupply asc + p@(Pulsing _ _) -> liftSTS $ runProvM $ completeStep p + p@(Complete _) -> pure p + -- More blocks to come, get things started or take a step + (False, False) -> + case ru of + Waiting -> liftSTS $ runProvM $ pure $ startStep slotsPerEpoch b es maxsupply asc + p@(Pulsing _ _) -> liftSTS $ runProvM $ pulseStep p + p@(Complete _) -> pure p diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs index 31a3e02165..ebc86e7248 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs @@ -23,7 +23,7 @@ module Shelley.Spec.Ledger.STS.Tick where import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Era (Crypto)) +import Cardano.Ledger.Era (Era) import Cardano.Ledger.Shelley.Constraints (UsesTxOut, UsesValue) import Control.Monad.Trans.Reader (asks) import Control.SetAlgebra (eval, (⨃)) @@ -31,17 +31,9 @@ import Control.State.Transition import qualified Data.Map.Strict as Map import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) -import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, StrictMaybe, epochInfo) +import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, epochInfo) import Shelley.Spec.Ledger.Keys (GenDelegs (..)) -import Shelley.Spec.Ledger.LedgerState - ( DPState (..), - DState (..), - EpochState (..), - FutureGenDeleg (..), - LedgerState (..), - NewEpochState (..), - RewardUpdate, - ) +import Shelley.Spec.Ledger.LedgerState (DPState (..), DState (..), EpochState (..), FutureGenDeleg (..), LedgerState (..), NewEpochState (..), PulsingRewUpdate) import Shelley.Spec.Ledger.STS.NewEpoch (NEWEPOCH, NewEpochPredicateFailure) import Shelley.Spec.Ledger.STS.Rupd (RUPD, RupdEnv (..), RupdPredicateFailure) import Shelley.Spec.Ledger.Slot (EpochNo, SlotNo, epochInfoEpoch) @@ -80,7 +72,7 @@ instance State (TICK era) ~ NewEpochState era, BaseM (TICK era) ~ ShelleyBase, Environment (Core.EraRule "RUPD" era) ~ RupdEnv era, - State (Core.EraRule "RUPD" era) ~ StrictMaybe (RewardUpdate (Crypto era)), + State (Core.EraRule "RUPD" era) ~ PulsingRewUpdate ShelleyBase era, Signal (Core.EraRule "RUPD" era) ~ SlotNo, Environment (Core.EraRule "NEWEPOCH" era) ~ (), State (Core.EraRule "NEWEPOCH" era) ~ NewEpochState era, @@ -163,7 +155,7 @@ bheadTransition :: State (TICK era) ~ NewEpochState era, BaseM (TICK era) ~ ShelleyBase, Environment (Core.EraRule "RUPD" era) ~ RupdEnv era, - State (Core.EraRule "RUPD" era) ~ StrictMaybe (RewardUpdate (Crypto era)), + State (Core.EraRule "RUPD" era) ~ PulsingRewUpdate ShelleyBase era, Signal (Core.EraRule "RUPD" era) ~ SlotNo, Environment (Core.EraRule "NEWEPOCH" era) ~ (), State (Core.EraRule "NEWEPOCH" era) ~ NewEpochState era, diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs index 7975f9cd63..9f5c555588 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs @@ -92,6 +92,7 @@ import Shelley.Spec.Ledger.Delegation.Certificates (IndividualPoolStake (..)) import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..)) import Shelley.Spec.Ledger.LedgerState ( FutureGenDeleg, + PulsingRewUpdate(..), ) import qualified Shelley.Spec.Ledger.Metadata as MD import Shelley.Spec.Ledger.RewardProvenance @@ -138,7 +139,7 @@ import Test.Shelley.Spec.Ledger.Serialisation.Generators.Bootstrap ( genBootstrapAddress, genSignature, ) -import Test.Tasty.QuickCheck (Gen, choose, elements) +import Test.Tasty.QuickCheck (Gen, choose, elements, frequency) import Control.State.Transition (STS (State)) import Cardano.Ledger.SafeHash(SafeHash, HasAlgorithm, unsafeMakeSafeHash) @@ -899,3 +900,7 @@ instance <*> arbitrary <*> arbitrary <*> arbitrary + +instance (Monad m,Era era) => Arbitrary (PulsingRewUpdate m era) where + arbitrary = frequency [(1,Complete <$> arbitrary),(1,pure Waiting)] + -- We don't generate any (Pulsing _ _), because they follow from Waiting \ No newline at end of file diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs index 35c7d70384..2b84d65aab 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs @@ -57,7 +57,7 @@ import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) import Data.Word (Word64) import GHC.Records (HasField) -import Shelley.Spec.Ledger.BaseTypes (Nonce (..), StrictMaybe (..), (⭒)) +import Shelley.Spec.Ledger.BaseTypes (Nonce (..), (⭒)) import Shelley.Spec.Ledger.BlockChain ( BHBody (..), Block (..), @@ -89,6 +89,7 @@ import Shelley.Spec.Ledger.LedgerState FutureGenDeleg (..), InstantaneousRewards (..), LedgerState (..), + PulsingRewUpdate(..), NewEpochState (..), PPUPState (..), PState (..), @@ -481,7 +482,7 @@ rewardUpdate :: ChainState era rewardUpdate ru cs = cs {chainNes = nes'} where - nes' = (chainNes cs) {nesRu = SJust ru} + nes' = (chainNes cs) {nesRu = Complete ru} -- | = Apply a Reward Update -- @@ -495,7 +496,7 @@ applyRewardUpdate ru cs = cs {chainNes = nes'} where nes = chainNes cs es' = applyRUpd ru (nesEs nes) - nes' = (chainNes cs) {nesEs = es', nesRu = SNothing} + nes' = (chainNes cs) {nesEs = es', nesRu = Waiting} -- | = New Snapshot -- diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs index 874ab8620e..6979ed239a 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs @@ -127,6 +127,7 @@ import Shelley.Spec.Ledger.LedgerState EpochState (..), NewEpochState (..), RewardUpdate (..), + PulsingRewUpdate(Complete), ) import qualified Shelley.Spec.Ledger.Metadata as MD import Shelley.Spec.Ledger.OCert @@ -1294,7 +1295,7 @@ tests = nm = def es = EpochState @C ac ss ls pps pps nm ru = - ( SJust + ( Complete $ RewardUpdate { deltaT = DeltaCoin 100, deltaR = DeltaCoin (-200), @@ -1302,8 +1303,7 @@ tests = deltaF = DeltaCoin (-10), nonMyopic = nm } - ) :: - StrictMaybe (RewardUpdate C_Crypto) + ) pd = PoolDistr @C_Crypto Map.empty nes = NewEpochState From fd1ccd47618135fa8f8dec4a21d774489119ca32 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Thu, 11 Feb 2021 19:15:24 -0800 Subject: [PATCH 15/18] Added completion to newEpochTransition --- semantics/executable-spec/src/Data/Pulse.hs | 1 + .../src/Shelley/Spec/Ledger/LedgerState.hs | 17 ++++++++-- .../src/Shelley/Spec/Ledger/Rewards.hs | 31 +++++-------------- .../src/Shelley/Spec/Ledger/STS/NewEpoch.hs | 17 +++++++--- .../src/Shelley/Spec/Ledger/STS/Rupd.hs | 1 + 5 files changed, 37 insertions(+), 30 deletions(-) diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs index b7f8f012e9..d8333a7583 100644 --- a/semantics/executable-spec/src/Data/Pulse.hs +++ b/semantics/executable-spec/src/Data/Pulse.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RankNTypes #-} module Data.Pulse where diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 922b3d7382..7081721a32 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -1072,6 +1072,17 @@ applyRUpd -- pulsestate } nm' = nonMyopic ru +{- +applyPulse :: + Monad m => + PulsingRewUpdate m era -> + EpochState era -> + ProvM (RewardProvenance (Crypto era)) m (EpochState era) +applyPulse pulsestate epochstate = do + ru <- completeRupd pulsestate + pure(applyRUpd ru epochstate) +-} + decayFactor :: Float decayFactor = 0.9 @@ -1246,7 +1257,7 @@ pulseStep :: Monad m => PulsingRewUpdate m era -> ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era) -pulseStep Waiting = pure Waiting +pulseStep Waiting = error ("\n\n ****************** Waiting i startStep ***********************\n\n") pulseStep (Complete r) = pure (Complete r) pulseStep (p@(Pulsing _ pulser)) | done pulser = completeStep p pulseStep (Pulsing rewsnap pulser) = do @@ -1259,7 +1270,7 @@ completeStep :: Monad m => PulsingRewUpdate m era -> ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era) -completeStep Waiting = error ("Can't complete a Waiting step") +completeStep Waiting = error ("\n\n ********************** Can't complete a Waiting step ************************\n") completeStep (Complete r) = pure (Complete r) completeStep (Pulsing rewsnap pulser) = do p2 <- completeRupd (Pulsing rewsnap pulser) @@ -1273,7 +1284,7 @@ completeRupd :: Monad m => PulsingRewUpdate m era -> ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) -completeRupd Waiting = error "Tried to complete a Waiting PulsingRewUpdate, this should be unreachable." +completeRupd Waiting = error ("\n\n ********************** Waiting in completeRupd ***********************\n\n.") completeRupd (Complete x) = pure x completeRupd ( Pulsing diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs index d71177e353..90e48fe5a9 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs @@ -613,23 +613,6 @@ reward :: reward pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch = completeM (rewardPulser pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch) -{- - r - addrsRew - poolParams - stake - delegs - (Coin totalStake) - asc - slotsPerEpoch - where - totalBlocks = sum b - Coin activeStake = fold . unStake $ stake - free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch) - pulser :: RewardPulser m era - pulser = SLP 2 (Close RewardStakePool :$ free) (Map.toList poolParams) (Map.empty, Map.empty) --} - rewardPulser :: forall m era. (Monad m) => @@ -721,15 +704,17 @@ instance Era era => FromCBOR (FreeVars era) where -- The function that we call on each pulseM rewardStakePool :: - forall m era. - (Monad m) => + forall era. FreeVars era -> RewardAns (Crypto era) -> PulseItem (Crypto era) -> - ProvM - (KeyHashPoolProvenance (Crypto era)) - m - (RewardAns (Crypto era)) + ( forall m. + Monad m => + ProvM + (KeyHashPoolProvenance (Crypto era)) + m + (RewardAns (Crypto era)) + ) rewardStakePool (FreeVars {b, delegs, stake, addrsRew, totalStake, activeStake, asc, totalBlocks, r, pp, slotsPerEpoch}) (m1, m2) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs index 281cfa5c65..fb984f70ab 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs @@ -24,6 +24,7 @@ import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Shelley.Constraints (UsesTxOut, UsesValue) import qualified Cardano.Ledger.Val as Val +import Control.Provenance (runProvM) import Control.State.Transition import Data.Default.Class (Default, def) import qualified Data.Map.Strict as Map @@ -79,7 +80,8 @@ instance Environment (Core.EraRule "EPOCH" era) ~ (), State (Core.EraRule "EPOCH" era) ~ EpochState era, Signal (Core.EraRule "EPOCH" era) ~ EpochNo, - Default (EpochState era) + Default (EpochState era), + Default (State (Core.EraRule "PPUP" era)) ) => STS (NEWEPOCH era) where @@ -114,7 +116,10 @@ newEpochTransition :: Signal (Core.EraRule "MIR" era) ~ (), Environment (Core.EraRule "EPOCH" era) ~ (), State (Core.EraRule "EPOCH" era) ~ EpochState era, - Signal (Core.EraRule "EPOCH" era) ~ EpochNo + Signal (Core.EraRule "EPOCH" era) ~ EpochNo, + UsesTxOut era, + UsesValue era, + Default (State (Core.EraRule "PPUP" era)) ) => TransitionRule (NEWEPOCH era) newEpochTransition = do @@ -128,8 +133,12 @@ newEpochTransition = do then pure src else do es' <- case ru of - Waiting -> pure es - Pulsing _ _ -> error "Pulsing state in newEpochTransition" -- TODO What can we do about this? + Waiting -> error ("\n\n *********************************************\nSTOP\n****************************\n") --pure es + p@(Pulsing _ _) -> do + ru'@(RewardUpdate dt dr rs_ df _) <- liftSTS $ runProvM $ completeRupd p + let totRs = sumRewards (esPrevPp es) rs_ + Val.isZero (dt <> (dr <> (toDeltaCoin totRs) <> df)) ?! CorruptRewardUpdate ru' + pure $ applyRUpd ru' es Complete ru' -> do let RewardUpdate dt dr rs_ df _ = ru' totRs = sumRewards (esPrevPp es) rs_ diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs index 96f0c372fb..06c6295f0b 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs @@ -16,6 +16,7 @@ module Shelley.Spec.Ledger.STS.Rupd completeStep, lift, Identity (..), + createRUpd, ) where From 4baa28918b1bf5b7aa84875b41eb4a31b0db3507 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Fri, 12 Feb 2021 06:59:30 -0800 Subject: [PATCH 16/18] Removed Waiting as constructor of PulsingRewUpdate, and use (StrictMaybe(PulsingRewUpdate)) instead --- .../Spec/Ledger/API/ByronTranslation.hs | 3 +-- .../src/Shelley/Spec/Ledger/LedgerState.hs | 22 ++++++------------- .../src/Shelley/Spec/Ledger/STS/Chain.hs | 4 ++-- .../src/Shelley/Spec/Ledger/STS/NewEpoch.hs | 10 ++++----- .../src/Shelley/Spec/Ledger/STS/Rupd.hs | 21 +++++++++--------- .../src/Shelley/Spec/Ledger/STS/Tick.hs | 6 ++--- .../Serialisation/EraIndepGenerators.hs | 6 ++--- .../Spec/Ledger/Examples/Combinators.hs | 8 +++---- .../Ledger/Serialisation/Golden/Encoding.hs | 4 ++-- 9 files changed, 38 insertions(+), 46 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs index 3920d1c590..fe580f9690 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs @@ -32,7 +32,6 @@ import Shelley.Spec.Ledger.API.Types import Shelley.Spec.Ledger.Coin (CompactForm (CompactCoin)) import Shelley.Spec.Ledger.CompactAddr (CompactAddr (UnsafeCompactAddr)) import Shelley.Spec.Ledger.EpochBoundary -import Shelley.Spec.Ledger.LedgerState (PulsingRewUpdate (Waiting)) import Shelley.Spec.Ledger.STS.Chain (pparamsToChainChecksData) import Shelley.Spec.Ledger.Slot @@ -99,7 +98,7 @@ translateToShelleyLedgerState genesisShelley epochNo cvs = nesBprev = BlocksMade Map.empty, nesBcur = BlocksMade Map.empty, nesEs = epochState, - nesRu = Waiting, + nesRu = SNothing, nesPd = PoolDistr Map.empty } where diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 7081721a32..cbb3e35283 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -625,7 +625,7 @@ data NewEpochState era = NewEpochState nesEs :: !(EpochState era), -- | Possible reward update -- nesRu :: !(StrictMaybe (RewardUpdate (Crypto era))), - nesRu :: !(PulsingRewUpdate ShelleyBase era), + nesRu :: !(StrictMaybe (PulsingRewUpdate ShelleyBase era)), -- | Stake distribution within the stake pool nesPd :: !(PoolDistr (Crypto era)) } @@ -1037,7 +1037,6 @@ stakeDistr u ds ps = -- | Apply a reward update applyRUpd :: - -- PulsingRewUpdate ShelleyBase era -> RewardUpdate (Crypto era) -> EpochState era -> EpochState era @@ -1140,24 +1139,21 @@ instance Era era => FromCBOR (RewardSnapShot era) where -- | State used in the STS rules data PulsingRewUpdate m era - = Waiting - | Pulsing !(RewardSnapShot era) !(RewardPulser m era) + = Pulsing !(RewardSnapShot era) !(RewardPulser m era) | Complete !(RewardUpdate (Crypto era)) deriving (Eq, Show, Generic, NoThunks) instance NFData (PulsingRewUpdate m era) instance (Typeable m, Era era) => ToCBOR (PulsingRewUpdate m era) where - toCBOR Waiting = encode (Sum Waiting 0) - toCBOR (Pulsing s p) = encode (Sum Pulsing 1 !> To s !> To p) - toCBOR (Complete r) = encode (Sum (Complete @m @era) 2 !> To r) + toCBOR (Pulsing s p) = encode (Sum Pulsing 0 !> To s !> To p) + toCBOR (Complete r) = encode (Sum (Complete @m @era) 1 !> To r) instance (Monad m, Typeable m, Era era) => FromCBOR (PulsingRewUpdate m era) where fromCBOR = decode (Summands "PulsingRewUpdate" decPS) where - decPS 0 = (SumD Waiting) - decPS 1 = (SumD Pulsing PulsingRewUpdate m era -> ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era) -pulseStep Waiting = error ("\n\n ****************** Waiting i startStep ***********************\n\n") pulseStep (Complete r) = pure (Complete r) pulseStep (p@(Pulsing _ pulser)) | done pulser = completeStep p pulseStep (Pulsing rewsnap pulser) = do @@ -1270,7 +1265,6 @@ completeStep :: Monad m => PulsingRewUpdate m era -> ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era) -completeStep Waiting = error ("\n\n ********************** Can't complete a Waiting step ************************\n") completeStep (Complete r) = pure (Complete r) completeStep (Pulsing rewsnap pulser) = do p2 <- completeRupd (Pulsing rewsnap pulser) @@ -1284,7 +1278,6 @@ completeRupd :: Monad m => PulsingRewUpdate m era -> ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era)) -completeRupd Waiting = error ("\n\n ********************** Waiting in completeRupd ***********************\n\n.") completeRupd (Complete x) = pure x completeRupd ( Pulsing @@ -1349,8 +1342,7 @@ createRUpd slotsPerEpoch blocksmade epstate maxSupply asc = do step3 <- completeStep step2 case step3 of Complete rewupdate -> pure rewupdate - Waiting -> error "Wait never returned by completeStep" - Pulsing _ _ -> error "Pulsing never returned by completeStep" + Pulsing _ _ -> error "\n\n ********* Pulsing never returned by completeStep ***************\n\n" -- completeStep $ startStep slotsPerEpoch b es maxsupply asc diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs index 43a2989c85..53aac60135 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs @@ -60,6 +60,7 @@ import Shelley.Spec.Ledger.BaseTypes ( Globals (..), Nonce (..), ShelleyBase, + StrictMaybe (..), ) import Shelley.Spec.Ledger.BlockChain ( BHeader, @@ -92,7 +93,6 @@ import Shelley.Spec.Ledger.LedgerState LedgerState (..), NewEpochState (..), PState (..), - PulsingRewUpdate (..), TransUTxOState, UTxOState (..), updateNES, @@ -213,7 +213,7 @@ initialShelleyState lab e utxo reserves genDelegs pp initNonce = pp def ) - Waiting + SNothing (PoolDistr Map.empty) ) cs diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs index fb984f70ab..a7b1e83aca 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs @@ -101,7 +101,7 @@ instance (BlocksMade Map.empty) (BlocksMade Map.empty) def - Waiting + SNothing (PoolDistr Map.empty) ] @@ -133,13 +133,13 @@ newEpochTransition = do then pure src else do es' <- case ru of - Waiting -> error ("\n\n *********************************************\nSTOP\n****************************\n") --pure es - p@(Pulsing _ _) -> do + SNothing -> pure es + SJust (p@(Pulsing _ _)) -> do ru'@(RewardUpdate dt dr rs_ df _) <- liftSTS $ runProvM $ completeRupd p let totRs = sumRewards (esPrevPp es) rs_ Val.isZero (dt <> (dr <> (toDeltaCoin totRs) <> df)) ?! CorruptRewardUpdate ru' pure $ applyRUpd ru' es - Complete ru' -> do + SJust (Complete ru') -> do let RewardUpdate dt dr rs_ df _ = ru' totRs = sumRewards (esPrevPp es) rs_ Val.isZero (dt <> (dr <> (toDeltaCoin totRs) <> df)) ?! CorruptRewardUpdate ru' @@ -155,7 +155,7 @@ newEpochTransition = do bcur (BlocksMade Map.empty) es''' - Waiting + SNothing pd' calculatePoolDistr :: SnapShot crypto -> PoolDistr crypto diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs index 06c6295f0b..c7981bd8a1 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs @@ -40,6 +40,7 @@ import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Shelley.Spec.Ledger.BaseTypes ( ShelleyBase, + StrictMaybe (..), activeSlotCoeff, epochInfo, maxLovelaceSupply, @@ -115,13 +116,13 @@ rupdTransition = do -} instance (Era era) => STS (RUPD era) where - type State (RUPD era) = PulsingRewUpdate ShelleyBase era + type State (RUPD era) = StrictMaybe (PulsingRewUpdate ShelleyBase era) type Signal (RUPD era) = SlotNo type Environment (RUPD era) = RupdEnv era type BaseM (RUPD era) = ShelleyBase type PredicateFailure (RUPD era) = RupdPredicateFailure era - initialRules = [pure Waiting] + initialRules = [pure SNothing] transitionRules = [rupdTransition] rupdTransition :: Era era => TransitionRule (RUPD era) @@ -140,17 +141,17 @@ rupdTransition = do let maxsupply = Coin (fromIntegral maxLL) case (s <= slot, s == lastblock) of -- Waiting for the stabiliy point, do nothing, keep waiting - (True, _) -> pure Waiting - (False, _) | ((2 * 2 == 2 + (2 :: Int))) -> liftSTS $ runProvM $ Complete <$> createRUpd slotsPerEpoch b es maxsupply asc + (True, _) -> pure SNothing + (False, _) | ((2 * 2 == 2 + (2 :: Int))) -> liftSTS $ runProvM $ (SJust . Complete) <$> createRUpd slotsPerEpoch b es maxsupply asc -- We are in the last block, finish everything up (False, True) -> case ru of - Waiting -> liftSTS $ runProvM $ completeStep $ startStep slotsPerEpoch b es maxsupply asc - p@(Pulsing _ _) -> liftSTS $ runProvM $ completeStep p - p@(Complete _) -> pure p + SNothing -> liftSTS $ runProvM $ SJust <$> completeStep (startStep slotsPerEpoch b es maxsupply asc) + (SJust (p@(Pulsing _ _))) -> SJust <$> (liftSTS $ runProvM $ completeStep p) + (SJust (p@(Complete _))) -> pure (SJust p) -- More blocks to come, get things started or take a step (False, False) -> case ru of - Waiting -> liftSTS $ runProvM $ pure $ startStep slotsPerEpoch b es maxsupply asc - p@(Pulsing _ _) -> liftSTS $ runProvM $ pulseStep p - p@(Complete _) -> pure p + SNothing -> liftSTS $ runProvM $ pure $ SJust $ startStep slotsPerEpoch b es maxsupply asc + (SJust (p@(Pulsing _ _))) -> liftSTS $ runProvM $ (SJust <$> pulseStep p) + (SJust (p@(Complete _))) -> pure (SJust p) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs index ebc86e7248..aa3a280c1f 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs @@ -31,7 +31,7 @@ import Control.State.Transition import qualified Data.Map.Strict as Map import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) -import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, epochInfo) +import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), epochInfo) import Shelley.Spec.Ledger.Keys (GenDelegs (..)) import Shelley.Spec.Ledger.LedgerState (DPState (..), DState (..), EpochState (..), FutureGenDeleg (..), LedgerState (..), NewEpochState (..), PulsingRewUpdate) import Shelley.Spec.Ledger.STS.NewEpoch (NEWEPOCH, NewEpochPredicateFailure) @@ -72,7 +72,7 @@ instance State (TICK era) ~ NewEpochState era, BaseM (TICK era) ~ ShelleyBase, Environment (Core.EraRule "RUPD" era) ~ RupdEnv era, - State (Core.EraRule "RUPD" era) ~ PulsingRewUpdate ShelleyBase era, + State (Core.EraRule "RUPD" era) ~ StrictMaybe (PulsingRewUpdate ShelleyBase era), Signal (Core.EraRule "RUPD" era) ~ SlotNo, Environment (Core.EraRule "NEWEPOCH" era) ~ (), State (Core.EraRule "NEWEPOCH" era) ~ NewEpochState era, @@ -155,7 +155,7 @@ bheadTransition :: State (TICK era) ~ NewEpochState era, BaseM (TICK era) ~ ShelleyBase, Environment (Core.EraRule "RUPD" era) ~ RupdEnv era, - State (Core.EraRule "RUPD" era) ~ PulsingRewUpdate ShelleyBase era, + State (Core.EraRule "RUPD" era) ~ StrictMaybe (PulsingRewUpdate ShelleyBase era), Signal (Core.EraRule "RUPD" era) ~ SlotNo, Environment (Core.EraRule "NEWEPOCH" era) ~ (), State (Core.EraRule "NEWEPOCH" era) ~ NewEpochState era, diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs index 9f5c555588..855f0a0abd 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs @@ -139,7 +139,7 @@ import Test.Shelley.Spec.Ledger.Serialisation.Generators.Bootstrap ( genBootstrapAddress, genSignature, ) -import Test.Tasty.QuickCheck (Gen, choose, elements, frequency) +import Test.Tasty.QuickCheck (Gen, choose, elements) import Control.State.Transition (STS (State)) import Cardano.Ledger.SafeHash(SafeHash, HasAlgorithm, unsafeMakeSafeHash) @@ -902,5 +902,5 @@ instance <*> arbitrary instance (Monad m,Era era) => Arbitrary (PulsingRewUpdate m era) where - arbitrary = frequency [(1,Complete <$> arbitrary),(1,pure Waiting)] - -- We don't generate any (Pulsing _ _), because they follow from Waiting \ No newline at end of file + arbitrary = Complete <$> arbitrary + -- We don't generate any (Pulsing _ _), because they follow from SNothing \ No newline at end of file diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs index 2b84d65aab..10d975caa2 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs @@ -57,7 +57,7 @@ import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) import Data.Word (Word64) import GHC.Records (HasField) -import Shelley.Spec.Ledger.BaseTypes (Nonce (..), (⭒)) +import Shelley.Spec.Ledger.BaseTypes (Nonce (..), StrictMaybe(..), (⭒)) import Shelley.Spec.Ledger.BlockChain ( BHBody (..), Block (..), @@ -89,11 +89,11 @@ import Shelley.Spec.Ledger.LedgerState FutureGenDeleg (..), InstantaneousRewards (..), LedgerState (..), - PulsingRewUpdate(..), NewEpochState (..), PPUPState (..), PState (..), RewardUpdate (..), + PulsingRewUpdate(..), UTxOState (..), applyRUpd, ) @@ -482,7 +482,7 @@ rewardUpdate :: ChainState era rewardUpdate ru cs = cs {chainNes = nes'} where - nes' = (chainNes cs) {nesRu = Complete ru} + nes' = (chainNes cs) {nesRu = SJust(Complete ru)} -- | = Apply a Reward Update -- @@ -496,7 +496,7 @@ applyRewardUpdate ru cs = cs {chainNes = nes'} where nes = chainNes cs es' = applyRUpd ru (nesEs nes) - nes' = (chainNes cs) {nesEs = es', nesRu = Waiting} + nes' = (chainNes cs) {nesEs = es', nesRu = SNothing} -- | = New Snapshot -- diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs index 6979ed239a..05acc50d34 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs @@ -1311,7 +1311,7 @@ tests = (BlocksMade bs) (BlocksMade bs) es - ru + (SJust ru) pd in checkEncodingCBOR "new_epoch_state" @@ -1321,7 +1321,7 @@ tests = <> S (BlocksMade @C_Crypto bs) <> S (BlocksMade @C_Crypto bs) <> S es - <> S ru + <> S (SJust ru) <> S pd ) ] From 41a4b143e8c5694dcc01d2d0433bd5a97b4bb352 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Fri, 12 Feb 2021 10:38:12 -0800 Subject: [PATCH 17/18] Mary era translations fixed. --- .../src/Cardano/Ledger/Allegra/Translation.hs | 19 ++++++++++++++++-- .../src/Cardano/Ledger/Mary/Translation.hs | 20 ++++++++++++++++--- .../src/Shelley/Spec/Ledger/LedgerState.hs | 6 ++---- .../src/Shelley/Spec/Ledger/STS/Rupd.hs | 2 +- 4 files changed, 37 insertions(+), 10 deletions(-) diff --git a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs index c535734355..2847586723 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs @@ -36,6 +36,9 @@ import qualified Shelley.Spec.Ledger.LedgerState as LS ( returnRedeemAddrsToReserves, ) import Shelley.Spec.Ledger.Tx (decodeWits) +import Shelley.Spec.Ledger.LedgerState(PulsingRewUpdate(..)) +import Data.Pulse(SLP(..)) +import Data.Closure(rootName) -------------------------------------------------------------------------------- -- Translation from Shelley to Allegra @@ -61,14 +64,18 @@ type instance PreviousEra (AllegraEra c) = ShelleyEra c type instance TranslationContext (AllegraEra c) = () instance Crypto c => TranslateEra (AllegraEra c) NewEpochState where - translateEra ctxt nes = + type TranslationError (AllegraEra c) NewEpochState = PulseError + translateEra ctxt nes = do + nesRu' <- case nesRu nes of + SNothing -> pure SNothing + SJust pulsrew -> SJust <$> translateEra ctxt pulsrew return $ NewEpochState { nesEL = nesEL nes, nesBprev = nesBprev nes, nesBcur = nesBcur nes, nesEs = translateEra' ctxt $ LS.returnRedeemAddrsToReserves . nesEs $ nes, - nesRu = nesRu nes, + nesRu = nesRu', nesPd = nesPd nes } @@ -186,3 +193,11 @@ instance Crypto c => TranslateEra (AllegraEra c) WitnessSet where instance Crypto c => TranslateEra (AllegraEra c) Update where translateEra _ (Update pp en) = pure $ Update (coerce pp) en + +data PulseError = PulseError String + +instance Crypto c => TranslateEra (AllegraEra c) (PulsingRewUpdate m) where + type TranslationError (AllegraEra c) (PulsingRewUpdate m) = PulseError + translateEra _ (Pulsing _ (SLP _ cl _ _)) = + throwError(PulseError ("The pulsing reward update did not run to completions: "++rootName cl)) + translateEra _ (Complete ru) = pure(Complete ru) diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs index 6a31fcd68e..5fa5f22196 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs @@ -41,6 +41,10 @@ import Shelley.Spec.Ledger.API hiding (Metadata, TxBody) import Shelley.Spec.Ledger.Tx ( decodeWits, ) +import Shelley.Spec.Ledger.LedgerState(PulsingRewUpdate(..)) +import Data.Pulse(SLP(..)) +import Data.Closure(rootName) +import Cardano.Ledger.Allegra.Translation(PulseError(..)) -------------------------------------------------------------------------------- -- Translation from Allegra to Mary @@ -66,14 +70,18 @@ type instance PreviousEra (MaryEra c) = AllegraEra c type instance TranslationContext (MaryEra c) = () instance Crypto c => TranslateEra (MaryEra c) NewEpochState where - translateEra ctxt nes = + type TranslationError (MaryEra c) NewEpochState = PulseError + translateEra ctxt nes = do + nesRu' <- case nesRu nes of + SNothing -> pure SNothing + SJust pulsrew -> SJust <$> translateEra ctxt pulsrew return $ - NewEpochState + NewEpochState { nesEL = nesEL nes, nesBprev = nesBprev nes, nesBcur = nesBcur nes, nesEs = translateEra' ctxt $ nesEs nes, - nesRu = nesRu nes, + nesRu = nesRu', nesPd = nesPd nes } @@ -185,3 +193,9 @@ translateCompactValue = fromMaybe (error msg) . toCompact . translateValue . fromCompact where msg = "impossible error: compact coin is out of range" + +instance Crypto c => TranslateEra (MaryEra c) (PulsingRewUpdate m) where + type TranslationError (MaryEra c) (PulsingRewUpdate m) = PulseError + translateEra _ (Pulsing _ (SLP _ cl _ _)) = + throwError(PulseError ("The pulsing reward update did not run to completions: "++rootName cl)) + translateEra _ (Complete ru) = pure(Complete ru) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index cbb3e35283..4fe15837de 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -1339,10 +1339,8 @@ createRUpd :: createRUpd slotsPerEpoch blocksmade epstate maxSupply asc = do step1 <- pure $ startStep slotsPerEpoch blocksmade epstate maxSupply asc step2 <- pulseStep step1 - step3 <- completeStep step2 - case step3 of - Complete rewupdate -> pure rewupdate - Pulsing _ _ -> error "\n\n ********* Pulsing never returned by completeStep ***************\n\n" + step3 <- completeRupd step2 + pure step3 -- completeStep $ startStep slotsPerEpoch b es maxsupply asc diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs index c7981bd8a1..e5d21e7397 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs @@ -142,7 +142,7 @@ rupdTransition = do case (s <= slot, s == lastblock) of -- Waiting for the stabiliy point, do nothing, keep waiting (True, _) -> pure SNothing - (False, _) | ((2 * 2 == 2 + (2 :: Int))) -> liftSTS $ runProvM $ (SJust . Complete) <$> createRUpd slotsPerEpoch b es maxsupply asc + -- (False, _) | ((2 * 2 == 2 + (2 :: Int))) -> liftSTS $ runProvM $ (SJust . Complete) <$> createRUpd slotsPerEpoch b es maxsupply asc -- We are in the last block, finish everything up (False, True) -> case ru of From 4609c5705872ebe5351c4afb990f6228dc45f22c Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Fri, 12 Feb 2021 10:39:28 -0800 Subject: [PATCH 18/18] ormolised --- .../src/Cardano/Ledger/Allegra/Translation.hs | 14 +++++++------- .../src/Cardano/Ledger/Mary/Translation.hs | 18 +++++++++--------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs index 2847586723..22865f77e2 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs @@ -29,16 +29,16 @@ import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Era hiding (Crypto) import Cardano.Ledger.Shelley (ShelleyEra) import Control.Monad.Except (throwError) +import Data.Closure (rootName) import Data.Coerce (coerce) import qualified Data.Map.Strict as Map +import Data.Pulse (SLP (..)) import Shelley.Spec.Ledger.API +import Shelley.Spec.Ledger.LedgerState (PulsingRewUpdate (..)) import qualified Shelley.Spec.Ledger.LedgerState as LS ( returnRedeemAddrsToReserves, ) import Shelley.Spec.Ledger.Tx (decodeWits) -import Shelley.Spec.Ledger.LedgerState(PulsingRewUpdate(..)) -import Data.Pulse(SLP(..)) -import Data.Closure(rootName) -------------------------------------------------------------------------------- -- Translation from Shelley to Allegra @@ -67,8 +67,8 @@ instance Crypto c => TranslateEra (AllegraEra c) NewEpochState where type TranslationError (AllegraEra c) NewEpochState = PulseError translateEra ctxt nes = do nesRu' <- case nesRu nes of - SNothing -> pure SNothing - SJust pulsrew -> SJust <$> translateEra ctxt pulsrew + SNothing -> pure SNothing + SJust pulsrew -> SJust <$> translateEra ctxt pulsrew return $ NewEpochState { nesEL = nesEL nes, @@ -199,5 +199,5 @@ data PulseError = PulseError String instance Crypto c => TranslateEra (AllegraEra c) (PulsingRewUpdate m) where type TranslationError (AllegraEra c) (PulsingRewUpdate m) = PulseError translateEra _ (Pulsing _ (SLP _ cl _ _)) = - throwError(PulseError ("The pulsing reward update did not run to completions: "++rootName cl)) - translateEra _ (Complete ru) = pure(Complete ru) + throwError (PulseError ("The pulsing reward update did not run to completions: " ++ rootName cl)) + translateEra _ (Complete ru) = pure (Complete ru) diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs index 5fa5f22196..06c64f05ab 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs @@ -23,6 +23,7 @@ import Cardano.Binary serialize, ) import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Allegra.Translation (PulseError (..)) import Cardano.Ledger.Compactible (Compactible (..)) import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Era hiding (Crypto) @@ -34,17 +35,16 @@ import Cardano.Ledger.ShelleyMA.AuxiliaryData ) import qualified Cardano.Ledger.Val as Val import Control.Monad.Except (throwError) +import Data.Closure (rootName) import Data.Coerce (coerce) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) +import Data.Pulse (SLP (..)) import Shelley.Spec.Ledger.API hiding (Metadata, TxBody) +import Shelley.Spec.Ledger.LedgerState (PulsingRewUpdate (..)) import Shelley.Spec.Ledger.Tx ( decodeWits, ) -import Shelley.Spec.Ledger.LedgerState(PulsingRewUpdate(..)) -import Data.Pulse(SLP(..)) -import Data.Closure(rootName) -import Cardano.Ledger.Allegra.Translation(PulseError(..)) -------------------------------------------------------------------------------- -- Translation from Allegra to Mary @@ -73,10 +73,10 @@ instance Crypto c => TranslateEra (MaryEra c) NewEpochState where type TranslationError (MaryEra c) NewEpochState = PulseError translateEra ctxt nes = do nesRu' <- case nesRu nes of - SNothing -> pure SNothing - SJust pulsrew -> SJust <$> translateEra ctxt pulsrew + SNothing -> pure SNothing + SJust pulsrew -> SJust <$> translateEra ctxt pulsrew return $ - NewEpochState + NewEpochState { nesEL = nesEL nes, nesBprev = nesBprev nes, nesBcur = nesBcur nes, @@ -197,5 +197,5 @@ translateCompactValue = instance Crypto c => TranslateEra (MaryEra c) (PulsingRewUpdate m) where type TranslationError (MaryEra c) (PulsingRewUpdate m) = PulseError translateEra _ (Pulsing _ (SLP _ cl _ _)) = - throwError(PulseError ("The pulsing reward update did not run to completions: "++rootName cl)) - translateEra _ (Complete ru) = pure(Complete ru) + throwError (PulseError ("The pulsing reward update did not run to completions: " ++ rootName cl)) + translateEra _ (Complete ru) = pure (Complete ru)