Tests all fixed, ormolised

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs

@@ -11,6 +11,7 @@
 
 module Test.Shelley.Spec.Ledger.Rewards (rewardTests, C, defaultMain) where
 
+import Data.Set(Set)
 import Cardano.Binary (toCBOR)
 import qualified Cardano.Crypto.DSIGN as Crypto
 import Cardano.Crypto.Hash (MD5, hashToBytes)
@@ -27,15 +28,15 @@ import Cardano.Ledger.Val (invert, (<+>), (<->))
 import Cardano.Slotting.Slot (EpochSize (..))
 import Control.Iterate.SetAlgebra (eval, (◁))
 import Control.Monad (replicateM)
-import Control.Monad.Identity (Identity (..))
 import Control.Monad.Trans.Reader (asks, runReader)
-import Control.Provenance (preservesJust, preservesNothing, runProvM, runWithProvM)
+import Control.Provenance (preservesJust, preservesNothing, ProvM, runProvM, runWithProvM)
 import Data.Default.Class (Default (def))
 import Data.Foldable (fold)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Proxy
+import Data.Pulse(Pulsable(..))
 import Data.Ratio (Ratio, (%))
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
@@ -106,6 +107,13 @@ import Shelley.Spec.Ledger.Rewards
     -- reward,
     sumRewards,
   )
+import Shelley.Spec.Ledger.RewardUpdate
+  ( KeyHashPoolProvenance,
+    RewardAns,
+    Pulser,
+    FreeVars(..),
+    RewardPulser(RSLP)
+  )
 import Shelley.Spec.Ledger.Slot (epochInfoSize)
 import Shelley.Spec.Ledger.TxBody (PoolParams (..), RewardAcnt (..))
 import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C)
@@ -116,6 +124,7 @@ import Test.Shelley.Spec.Ledger.Serialisation.Generators ()
 import Test.Shelley.Spec.Ledger.Utils
   ( testGlobals,
     unsafeMkUnitInterval,
+    runShelleyBase,
   )
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import Test.Tasty.HUnit (testCaseInfo)
@@ -302,7 +311,7 @@ rewardsBoundedByPot _ = property $ do
             pools
       totalLovelace = undelegatedLovelace <> fold stake
       slotsPerEpoch = EpochSize . fromIntegral $ totalBlocks + silentSlots
-      Identity rs =
+      rs = runShelleyBase $
         runProvM $
           reward
             (_d pp, _a0 pp, _nOpt pp)
@@ -369,9 +378,9 @@ rewardsProvenance _ = generate $ do
             pools
       totalLovelace = undelegatedLovelace <> fold stake
       slotsPerEpoch = EpochSize . fromIntegral $ totalBlocks + silentSlots
-      Identity (_, prov) =
+      (_, prov) = runShelleyBase $
         runWithProvM def $
-          reward @Identity @(Crypto era)
+          reward @(Crypto era)
             (_d pp, _a0 pp, _nOpt pp)
             bs
             rewardPot
@@ -713,3 +722,56 @@ rewardTests =
       testProperty "oldstyle (aggregate immediately) matches newstyle (late aggregation) with provenance on style" (oldEqualsNewOn @C),
       testCaseInfo "Reward Provenance works" (rewardsProvenance (Proxy @C))
     ]
+
+
+-- =================================
+-- An old style function used in the tests, which is reimplemented here
+-- using the newstyle
+
+
+reward ::
+  forall crypto.
+  (UnitInterval, Rational, Natural) ->
+  BlocksMade crypto ->
+  Coin ->
+  Set (Credential 'Staking crypto) ->
+  Map (KeyHash 'StakePool crypto) (PoolParams crypto) ->
+  Stake crypto ->
+  Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto) ->
+  Coin ->
+  ActiveSlotCoeff ->
+  EpochSize ->
+  ProvM (KeyHashPoolProvenance crypto) ShelleyBase (RewardAns crypto)
+reward pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch =
+  completeM (rewardPulser pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch)
+
+rewardPulser ::
+  forall c.
+  (UnitInterval, Rational, Natural) ->
+  BlocksMade c ->
+  Coin ->
+  Set (Credential 'Staking c) ->
+  Map (KeyHash 'StakePool c) (PoolParams c) ->
+  Stake c ->
+  Map (Credential 'Staking c) (KeyHash 'StakePool c) ->
+  Coin ->
+  ActiveSlotCoeff ->
+  EpochSize ->
+  Pulser c
+rewardPulser
+  (pp_d, pp_a0, pp_nOpt)
+  (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 slotsPerEpoch pp_d pp_a0 pp_nOpt)
+      pulser :: Pulser c
+      pulser = RSLP 2 free (Map.toList poolParams) (Map.empty, Map.empty)