From 25664e192002df87de5eff9bbd3e1cef859e8b27 Mon Sep 17 00:00:00 2001 From: TimSheard Date: Wed, 29 Mar 2023 09:37:14 -0700 Subject: [PATCH] Added Data.Incremental with class(ILC) and basic instances (Map,MonoidMap,Total) tests. Added ILC instances for Core: Coin, UMap, DPState, DState, PState, UTxOState etc. Added ILC instances for (Diff DPState), (Diff DState) (Diff UTxOstate) etc. Add property tests for ILC invariants for every ILC instance. Rewrote the "POOL" STS rule to use differences (Diff PState), and all the POOL tests Added the Conway era HSpec test directory: eras/conway/impl/test --- eras/conway/impl/cardano-ledger-conway.cabal | 20 ++ .../src/Cardano/Ledger/Conway/Governance.hs | 71 ++++- eras/conway/impl/test/Main.hs | 10 + .../Test/Cardano/Ledger/Conway/DiffSpec.hs | 31 +++ .../Test/Cardano/Ledger/Conway/Arbitrary.hs | 40 +++ .../cardano-ledger-conway-test.cabal | 5 +- eras/conway/test-suite/test/Tests.hs | 1 + .../src/Cardano/Ledger/Shelley/Governance.hs | 30 ++- .../src/Cardano/Ledger/Shelley/LedgerState.hs | 3 + .../Ledger/Shelley/LedgerState/Types.hs | 72 +++++ .../src/Cardano/Ledger/Shelley/PParams.hs | 3 +- .../src/Cardano/Ledger/Shelley/Rules/Delpl.hs | 18 +- .../src/Cardano/Ledger/Shelley/Rules/Pool.hs | 38 +-- .../Test/Cardano/Ledger/Shelley/Arbitrary.hs | 24 +- .../cardano-ledger-shelley-test.cabal | 3 +- .../Cardano/Ledger/Shelley/PropertyTests.hs | 11 + .../Test/Cardano/Ledger/Shelley/Rules/Pool.hs | 48 ++-- .../Cardano/Ledger/Shelley/Rules/TestChain.hs | 10 +- .../Ledger/Shelley/ShelleyDiffTests.hs | 36 +++ .../Ledger/Shelley/Examples/NetworkID.hs | 5 +- hie.yaml | 3 + libs/cardano-data/cardano-data.cabal | 7 +- libs/cardano-data/src/Data/Incremental.hs | 251 ++++++++++++++++++ libs/cardano-data/test/Main.hs | 2 + .../test/Test/Cardano/Data/IlcTest.hs | 146 ++++++++++ .../cardano-data/testlib/Test/Cardano/Data.hs | 144 ++++++++++ .../cardano-ledger-core.cabal | 3 + .../src/Cardano/Ledger/Coin.hs | 19 ++ .../src/Cardano/Ledger/DPState.hs | 82 +++++- .../src/Cardano/Ledger/UMapCompact.hs | 60 ++++- libs/cardano-ledger-core/test/Main.hs | 2 + .../test/Test/Cardano/Ledger/CoreDiffTests.hs | 71 +++++ .../Test/Cardano/Ledger/Core/Arbitrary.hs | 94 ++++++- 33 files changed, 1293 insertions(+), 70 deletions(-) create mode 100644 eras/conway/impl/test/Main.hs create mode 100644 eras/conway/impl/test/Test/Cardano/Ledger/Conway/DiffSpec.hs create mode 100644 eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/ShelleyDiffTests.hs create mode 100644 libs/cardano-data/src/Data/Incremental.hs create mode 100644 libs/cardano-data/test/Test/Cardano/Data/IlcTest.hs create mode 100644 libs/cardano-ledger-core/test/Test/Cardano/Ledger/CoreDiffTests.hs diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 3b6f71db945..ce90353b75e 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -58,6 +58,7 @@ library aeson, bytestring, cardano-crypto-class, + cardano-data, cardano-ledger-binary >=1.1, cardano-ledger-allegra >=1.1, cardano-ledger-alonzo >=1.1, @@ -97,3 +98,22 @@ library testlib cardano-ledger-core, cardano-ledger-mary:testlib, small-steps + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: Test.Cardano.Ledger.Conway.DiffSpec + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields + -Wunused-packages -threaded -rtsopts -with-rtsopts=-N + + build-depends: + base, + cardano-ledger-core:{cardano-ledger-core, testlib}, + cardano-ledger-conway, + testlib, + cardano-ledger-core, + cardano-data:testlib diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index ab76d845fad..dcc6e6b587f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -37,6 +38,7 @@ module Cardano.Ledger.Conway.Governance ( GovernanceProcedure (..), Anchor (..), AnchorDataHash, + Diff (EnactState', RatifyState', ConwayGovernance'), ) where import Cardano.Crypto.Hash.Class (hashToTextAsHex) @@ -74,6 +76,14 @@ import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=)) import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText) import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) +import Data.Functor.Identity (Identity) +import Data.Incremental ( + Diff (Total', Zero), + ILC (..), + Total, + applyTotal, + ($$), + ) import Data.Map.Strict (Map) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) @@ -438,6 +448,16 @@ data EnactState era = EnactState } deriving (Generic) +instance ILC (EnactState era) where + newtype Diff (EnactState era) = EnactState' (Diff (Total (EnactState era))) + applyDiff x (EnactState' y) = applyTotal x y + extend (EnactState' x) (EnactState' y) = EnactState' $ extend x y + zero = EnactState' Zero + totalDiff x = EnactState' (Total' x) + +deriving instance Eq (PParamsHKD Identity era) => Eq (Diff (EnactState era)) +deriving instance Show (PParamsHKD Identity era) => Show (Diff (EnactState era)) + instance EraPParams era => ToJSON (EnactState era) where toJSON = object . toEnactStatePairs toEncoding = pairs . mconcat . toEnactStatePairs @@ -453,8 +473,7 @@ toEnactStatePairs cg@(EnactState _ _ _ _ _ _) = , "withdrawals" .= ensWithdrawals ] -deriving instance Eq (PParams era) => Eq (EnactState era) - +deriving instance (Eq (PParamsHKD Identity era), Eq (PParams era)) => Eq (EnactState era) deriving instance Show (PParams era) => Show (EnactState era) instance EraPParams era => Default (EnactState era) where @@ -505,6 +524,29 @@ data RatifyState era = RatifyState } deriving (Generic, Eq, Show) +instance ILC (RatifyState era) where + data Diff (RatifyState era) = RatifyState' + { diffRsEnactState :: !(Diff (EnactState era)) + , diffRsFuture :: !(Diff (Total (StrictSeq (GovernanceActionId (EraCrypto era), GovernanceActionState era)))) + } + applyDiff RatifyState {..} RatifyState' {..} = + RatifyState + { rsEnactState = rsEnactState $$ diffRsEnactState + , rsFuture = case diffRsFuture of + Zero -> rsFuture + Total' x -> x + } + extend x y = + RatifyState' + { diffRsEnactState = extend (diffRsEnactState x) (diffRsEnactState y) + , diffRsFuture = extend (diffRsFuture x) (diffRsFuture y) + } + zero = RatifyState' zero zero + totalDiff (RatifyState x y) = RatifyState' (totalDiff x) (Total' y) + +deriving instance EraPParams era => Eq (Diff (RatifyState era)) +deriving instance EraPParams era => Show (Diff (RatifyState era)) + instance EraPParams era => Default (RatifyState era) instance EraPParams era => DecCBOR (RatifyState era) where @@ -549,6 +591,31 @@ data ConwayGovernance era = ConwayGovernance } deriving (Generic, Eq, Show) +instance ILC (ConwayGovernance era) where + data Diff (ConwayGovernance era) = ConwayGovernance' + { diffCgTally :: !(Diff (Map (GovernanceActionId (EraCrypto era)) (GovernanceActionState era))) + , diffCgRatify :: !(Diff (RatifyState era)) + , diffCgVoterRoles :: !(Diff (Map (Credential 'Voting (EraCrypto era)) VoterRole)) + } + applyDiff ConwayGovernance {..} ConwayGovernance' {..} = + ConwayGovernance + { cgTally = ConwayTallyState (unConwayTallyState cgTally $$ diffCgTally) + , cgRatify = cgRatify $$ diffCgRatify + , cgVoterRoles = cgVoterRoles $$ diffCgVoterRoles + } + extend x y = + ConwayGovernance' + { diffCgTally = extend (diffCgTally x) (diffCgTally y) + , diffCgRatify = extend (diffCgRatify x) (diffCgRatify y) + , diffCgVoterRoles = extend (diffCgVoterRoles x) (diffCgVoterRoles y) + } + zero = ConwayGovernance' zero zero zero + totalDiff (ConwayGovernance (ConwayTallyState x) y z) = + ConwayGovernance' (totalDiff x) (totalDiff y) (totalDiff z) + +deriving instance (EraPParams era) => (Eq (Diff (ConwayGovernance era))) +deriving instance (EraPParams era) => (Show (Diff (ConwayGovernance era))) + cgTallyL :: Lens' (ConwayGovernance era) (ConwayTallyState era) cgTallyL = lens cgTally (\x y -> x {cgTally = y}) diff --git a/eras/conway/impl/test/Main.hs b/eras/conway/impl/test/Main.hs new file mode 100644 index 00000000000..412e436d3db --- /dev/null +++ b/eras/conway/impl/test/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.DiffSpec (conwayDiffSpecs) + +main :: IO () +main = + ledgerTestMain $ + describe "Conway tests" $ do + conwayDiffSpecs diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DiffSpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DiffSpec.hs new file mode 100644 index 00000000000..f99e8dd40ac --- /dev/null +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DiffSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Conway.DiffSpec (conwayDiffSpecs) where + +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Crypto (StandardCrypto) +import Test.Cardano.Data ( + propExtend, + propZero, + ) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.Arbitrary () + +-- ========================================================== + +conwayDiffSpecs :: Spec +conwayDiffSpecs = describe "ILC Diff tests" $ do + describe "Diff EnactState" $ do + propZero (arbitrary @(EnactState (ConwayEra StandardCrypto))) + propExtend (arbitrary @(EnactState (ConwayEra StandardCrypto))) arbitrary + describe "Diff RatifyState" $ do + propZero (arbitrary @(RatifyState (ConwayEra StandardCrypto))) + propExtend (arbitrary @(RatifyState (ConwayEra StandardCrypto))) arbitrary + describe "Diff GovernanceState" $ do + propZero (arbitrary @(GovernanceState (ConwayEra StandardCrypto))) + propExtend (arbitrary @(GovernanceState (ConwayEra StandardCrypto))) arbitrary + +-- To run theses tests in ghci, uncomment and type 'main' +-- main :: IO () +-- main = hspec $ conwayDiffSpecs diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index 27c67363e0f..a4ef4915d24 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -8,6 +9,7 @@ module Test.Cardano.Ledger.Conway.Arbitrary () where +import Cardano.Ledger.BaseTypes (StrictMaybe) import Cardano.Ledger.Binary (Sized) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Delegation.Certificates @@ -17,6 +19,7 @@ import Cardano.Ledger.Conway.Rules import Cardano.Ledger.Conway.TxBody import Cardano.Ledger.Crypto (Crypto) import Control.State.Transition.Extended (STS (Event)) +import Data.Functor.Identity (Identity) import Test.Cardano.Ledger.Alonzo.Arbitrary () import Test.Cardano.Ledger.Babbage.Arbitrary () import Test.Cardano.Ledger.Common @@ -230,3 +233,40 @@ instance Arbitrary (ConwayTickfEvent era) where arbitrary = undefined + +------------------------------------------------------------------------------------------ +-- Cardano.Ledger.Conway ILC instances --------------------------------------------------- +------------------------------------------------------------------------------------------ +{- +src/Cardano/Ledger/Conway/Governance.hs +448:instance ILC (EnactState era) where +521:instance ILC (RatifyState era) where +584:instance ILC (ConwayGovernance era) where +-} + +instance + ( Era era + , Arbitrary (PParamsHKD Identity era) + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + Arbitrary (Diff (EnactState era)) + where + arbitrary = EnactState' <$> arbitrary + +instance + ( Era era + , Arbitrary (PParamsHKD Identity era) + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + Arbitrary (Diff (RatifyState era)) + where + arbitrary = RatifyState' <$> arbitrary <*> arbitrary + +instance + ( Era era + , Arbitrary (PParamsHKD Identity era) + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + Arbitrary (Diff (ConwayGovernance era)) + where + arbitrary = ConwayGovernance' <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/eras/conway/test-suite/cardano-ledger-conway-test.cabal b/eras/conway/test-suite/cardano-ledger-conway-test.cabal index 2e901aee9c4..aeaca637fad 100644 --- a/eras/conway/test-suite/cardano-ledger-conway-test.cabal +++ b/eras/conway/test-suite/cardano-ledger-conway-test.cabal @@ -74,9 +74,10 @@ test-suite cardano-ledger-conway-test bytestring, cardano-ledger-allegra, cardano-ledger-alonzo, + cardano-data:testlib, cardano-ledger-babbage, - cardano-ledger-conway, + cardano-ledger-conway:{cardano-ledger-conway, testlib}, cardano-ledger-conway-test, - cardano-ledger-core, + cardano-ledger-core:{cardano-ledger-core, testlib}, cardano-ledger-shelley-test, tasty diff --git a/eras/conway/test-suite/test/Tests.hs b/eras/conway/test-suite/test/Tests.hs index 651a1928098..885a3513623 100644 --- a/eras/conway/test-suite/test/Tests.hs +++ b/eras/conway/test-suite/test/Tests.hs @@ -4,6 +4,7 @@ module Main where import Cardano.Ledger.Conway (Conway) +import Test.Cardano.Ledger.Common (hspec) import qualified Test.Cardano.Ledger.Conway.Serialisation.CDDL as CDDL import qualified Test.Cardano.Ledger.Conway.Serialisation.Roundtrip as Roundtrip import Test.Tasty (TestTree, defaultMain, testGroup) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs index 8ae2a4a5dce..4a72d8b007d 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,6 +13,7 @@ module Cardano.Ledger.Shelley.Governance ( EraGovernance (..), ShelleyPPUPState (..), + Diff (ShelleyPPUPState'), ) where import Cardano.Ledger.Binary ( @@ -23,13 +26,16 @@ import Cardano.Ledger.Binary ( import Cardano.Ledger.Binary.Coders (Decode (..), decode, ( Show (Diff (ShelleyPPUPState era)) + +deriving instance Eq (PParamsUpdate era) => Eq (Diff (ShelleyPPUPState era)) + deriving instance Show (PParamsUpdate era) => Show (ShelleyPPUPState era) deriving instance Eq (PParamsUpdate era) => Eq (ShelleyPPUPState era) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index 4f811127e75..041bec7f322 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs @@ -94,6 +94,9 @@ module Cardano.Ledger.Shelley.LedgerState ( lsUTxOStateL, utxosFeesL, utxosGovernanceL, + + -- * ILC instances + Diff (IStake', UTxOState', LedgerState'), ) where import Cardano.Ledger.DPState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index aa386b9a185..133c9085fa8 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -17,6 +17,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use record patterns" #-} module Cardano.Ledger.Shelley.LedgerState.Types where @@ -58,6 +61,7 @@ import Cardano.Ledger.Shelley.Era (ShelleyEra) import Cardano.Ledger.Shelley.PoolRank (NonMyopic (..)) import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate (..)) import Cardano.Ledger.TreeDiff (ToExpr) +import Cardano.Ledger.TxIn (TxIn) import Cardano.Ledger.UTxO (UTxO (..)) import Control.DeepSeq (NFData) import Control.Monad.State.Strict (evalStateT) @@ -65,6 +69,7 @@ import Control.Monad.Trans (MonadTrans (lift)) import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=)) import Data.Default.Class (Default, def) import Data.Group (Group, invert) +import Data.Incremental (ILC (..), MonoidMap (..), unMM, ($$)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import GHC.Generics (Generic) @@ -241,6 +246,27 @@ data IncrementalStake c = IStake } deriving (Generic, Show, Eq, Ord, NoThunks, NFData) +instance ILC (IncrementalStake c) where + data Diff (IncrementalStake c) = IStake' + { diffCredMap :: !(Diff (MonoidMap (Credential 'Staking c) Coin)) + , diffPtrMap :: !(Diff (MonoidMap Ptr Coin)) + } + applyDiff IStake {..} IStake' {..} = + IStake + { credMap = unMM (MM credMap $$ diffCredMap) + , ptrMap = unMM (MM ptrMap $$ diffPtrMap) + } + extend x y = + IStake' + { diffCredMap = extend (diffCredMap x) (diffCredMap y) + , diffPtrMap = extend (diffPtrMap x) (diffPtrMap y) + } + zero = IStake' mempty mempty + totalDiff (IStake x y) = IStake' (totalDiff (MM x)) (totalDiff (MM y)) + +deriving instance Eq (Diff (IncrementalStake c)) +deriving instance Show (Diff (IncrementalStake c)) + instance Crypto c => EncCBOR (IncrementalStake c) where encCBOR (IStake st dangle) = encodeListLen 2 <> encCBOR st <> encCBOR dangle @@ -294,6 +320,37 @@ data UTxOState era = UTxOState } deriving (Generic) +instance ILC (GovernanceState era) => ILC (UTxOState era) where + data Diff (UTxOState era) = UTxOState' + { diffUtxosUtxo :: !(Diff (Map (TxIn (EraCrypto era)) (TxOut era))) + , diffUtxosDeposited :: !(Diff Coin) + , diffUtxosFees :: !(Diff Coin) + , diffUtxosGovernance :: !(Diff (GovernanceState era)) + , diffUtxosStakeDistr :: !(Diff (IncrementalStake (EraCrypto era))) + } + applyDiff UTxOState {..} UTxOState' {..} = + UTxOState + { utxosUtxo = UTxO (unUTxO utxosUtxo $$ diffUtxosUtxo) + , utxosDeposited = utxosDeposited $$ diffUtxosDeposited + , utxosFees = utxosFees $$ diffUtxosFees + , utxosGovernance = utxosGovernance $$ diffUtxosGovernance + , utxosStakeDistr = utxosStakeDistr $$ diffUtxosStakeDistr + } + extend x y = + UTxOState' + { diffUtxosUtxo = extend (diffUtxosUtxo x) (diffUtxosUtxo y) + , diffUtxosDeposited = extend (diffUtxosDeposited x) (diffUtxosDeposited y) + , diffUtxosFees = extend (diffUtxosFees x) (diffUtxosFees y) + , diffUtxosGovernance = extend (diffUtxosGovernance x) (diffUtxosGovernance y) + , diffUtxosStakeDistr = extend (diffUtxosStakeDistr x) (diffUtxosStakeDistr y) + } + zero = UTxOState' zero zero zero zero zero + totalDiff (UTxOState (UTxO v) w x y z) = + UTxOState' (totalDiff v) (totalDiff w) (totalDiff x) (totalDiff y) (totalDiff z) + +deriving instance (Eq (Diff (GovernanceState era)), Eq (TxOut era)) => Eq (Diff (UTxOState era)) +deriving instance (Show (Diff (GovernanceState era)), Show (TxOut era)) => Show (Diff (UTxOState era)) + utxosUtxoL :: Lens' (UTxOState era) (UTxO era) utxosUtxoL = lens utxosUtxo (\x y -> x {utxosUtxo = y}) @@ -500,6 +557,21 @@ data LedgerState era = LedgerState } deriving (Generic) +instance ILC (GovernanceState era) => ILC (LedgerState era) where + data Diff (LedgerState era) = LedgerState' (Diff (UTxOState era)) (Diff (DPState (EraCrypto era))) + applyDiff (LedgerState x y) (LedgerState' xD yD) = LedgerState (x $$ xD) (y $$ yD) + zero = LedgerState' zero zero + extend (LedgerState' x y) (LedgerState' a b) = LedgerState' (extend x a) (extend y b) + totalDiff (LedgerState x y) = LedgerState' (totalDiff x) (totalDiff y) + +deriving instance + (Eq (Diff (GovernanceState era)), Eq (TxOut era)) => + Eq (Diff (LedgerState era)) + +deriving instance + (Show (TxOut era), Show (Diff (GovernanceState era))) => + Show (Diff (LedgerState era)) + lsUTxOStateL :: Lens' (LedgerState era) (UTxOState era) lsUTxOStateL = lens lsUTxOState (\x y -> x {lsUTxOState = y}) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/PParams.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/PParams.hs index 01233655e41..ff54b792d1f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/PParams.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/PParams.hs @@ -478,8 +478,7 @@ shelleyCommonPParamsHKDPairs px pp = ] -- | Update operation for protocol parameters structure @PParams@ -newtype ProposedPPUpdates era - = ProposedPPUpdates (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)) +newtype ProposedPPUpdates era = ProposedPPUpdates {unProposedPPUpdates :: Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)} deriving (Generic) deriving instance Eq (PParamsUpdate era) => Eq (ProposedPPUpdates era) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs index ab0f9c165ec..bc94ee0f1a6 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs @@ -51,6 +51,7 @@ import Cardano.Ledger.Shelley.TxBody ( import Cardano.Ledger.Slot (SlotNo) import Control.DeepSeq import Control.State.Transition +import Data.Incremental (ILC (..)) import Data.Typeable (Typeable) import Data.Word (Word8) import GHC.Generics (Generic) @@ -104,7 +105,7 @@ instance , Signal (EraRule "DELEG" era) ~ DCert (EraCrypto era) , Embed (EraRule "POOL" era) (ShelleyDELPL era) , Environment (EraRule "POOL" era) ~ PoolEnv era - , State (EraRule "POOL" era) ~ PState (EraCrypto era) + , State (EraRule "POOL" era) ~ Diff (PState (EraCrypto era)) , Signal (EraRule "POOL" era) ~ DCert (EraCrypto era) ) => STS (ShelleyDELPL era) @@ -165,21 +166,22 @@ delplTransition :: , Signal (EraRule "DELEG" era) ~ DCert (EraCrypto era) , Embed (EraRule "POOL" era) (ShelleyDELPL era) , Environment (EraRule "POOL" era) ~ PoolEnv era - , State (EraRule "POOL" era) ~ PState (EraCrypto era) + , State (EraRule "POOL" era) ~ Diff (PState (EraCrypto era)) , Signal (EraRule "POOL" era) ~ DCert (EraCrypto era) ) => TransitionRule (ShelleyDELPL era) delplTransition = do TRC (DelplEnv slot ptr pp acnt, d, c) <- judgmentContext + let pstate = dpsPState d case c of DCertPool (RegPool _) -> do - ps <- - trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, dpsPState d, c) - pure $ d {dpsPState = ps} + dps <- + trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp pstate, totalDiff pstate, c) + pure $ d {dpsPState = applyDiff pstate dps} DCertPool (RetirePool _ _) -> do - ps <- - trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, dpsPState d, c) - pure $ d {dpsPState = ps} + dps <- + trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp pstate, totalDiff pstate, c) + pure $ d {dpsPState = applyDiff pstate dps} DCertGenesis ConstitutionalDelegCert {} -> do ds <- trans @(EraRule "DELEG" era) $ TRC (DelegEnv slot ptr acnt pp, dpsDState d, c) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs index 4e5faf8f936..912e1277e59 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -39,6 +39,7 @@ import Cardano.Ledger.Binary ( import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Core import qualified Cardano.Ledger.Crypto as CC (Crypto (HASH)) +import Cardano.Ledger.DPState (Diff (..)) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import Cardano.Ledger.Shelley.Era (ShelleyPOOL) import qualified Cardano.Ledger.Shelley.HardForks as HardForks @@ -55,7 +56,7 @@ import Cardano.Ledger.Slot (EpochNo (..), SlotNo, epochInfoEpoch) import Control.DeepSeq import Control.Monad (forM_, when) import Control.Monad.Trans.Reader (asks) -import Control.SetAlgebra (dom, eval, setSingleton, singleton, (∈), (∉), (∪), (⋪), (⨃)) +import Control.SetAlgebra (dom, eval, (∈), (∉)) import Control.State.Transition ( STS (..), TRC (..), @@ -67,13 +68,14 @@ import Control.State.Transition ( (?!), ) import qualified Data.ByteString as BS +import Data.Incremental (deleteD, insertD, ($$)) import Data.Word (Word8) import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) data PoolEnv era - = PoolEnv !SlotNo !(PParams era) + = PoolEnv !SlotNo !(PParams era) !(PState (EraCrypto era)) deriving instance Show (PParams era) => Show (PoolEnv era) @@ -105,7 +107,7 @@ instance NoThunks (ShelleyPoolPredFailure era) instance NFData (ShelleyPoolPredFailure era) instance EraPParams era => STS (ShelleyPOOL era) where - type State (ShelleyPOOL era) = PState (EraCrypto era) + type State (ShelleyPOOL era) = Diff (PState (EraCrypto era)) type Signal (ShelleyPOOL era) = DCert (EraCrypto era) @@ -167,8 +169,8 @@ instance Era era => DecCBOR (ShelleyPoolPredFailure era) where poolDelegationTransition :: forall era. EraPParams era => TransitionRule (ShelleyPOOL era) poolDelegationTransition = do - TRC (PoolEnv slot pp, ps, c) <- judgmentContext - let stpools = psStakePoolParams ps + TRC (PoolEnv slot pp ps, ps', c) <- judgmentContext + let stpools = psStakePoolParams ps $$ diffPsStakePoolParams ps' let pv = pp ^. ppProtocolVersionL case c of DCertPool (RegPool poolParam) -> do @@ -198,10 +200,14 @@ poolDelegationTransition = do -- register new, Pool-Reg tellEvent $ RegisterPool hk pure $ - payPoolDeposit hk pp $ - ps - { psStakePoolParams = eval (psStakePoolParams ps ∪ singleton hk poolParam) - } + payPoolDeposit + hk + pp + (ps $$ ps') + ( ps' + { diffPsStakePoolParams = insertD hk poolParam <> diffPsStakePoolParams ps' + } + ) else do tellEvent $ ReregisterPool hk -- hk is already registered, so we want to reregister it. That means adding it to the @@ -212,9 +218,9 @@ poolDelegationTransition = do -- does it need to pay a new deposit (at the current deposit amount). But of course, -- if that has happened, we cannot be in this branch of the if statement. pure $ - ps - { psFutureStakePoolParams = eval (psFutureStakePoolParams ps ⨃ singleton hk poolParam) - , psRetiring = eval (setSingleton hk ⋪ psRetiring ps) + ps' + { diffPsFutureStakePoolParams = insertD hk poolParam <> diffPsFutureStakePoolParams ps' + , diffPsRetiring = deleteD hk <> diffPsRetiring ps' } DCertPool (RetirePool hk e) -> do -- note that pattern match is used instead of cwitness, as in the spec @@ -226,13 +232,13 @@ poolDelegationTransition = do (cepoch < e && e <= cepoch + maxEpoch) ?! StakePoolRetirementWrongEpochPOOL cepoch e (cepoch + maxEpoch) -- We just schedule it for retirement. When it is retired we refund the deposit (see POOLREAP) - pure $ ps {psRetiring = eval (psRetiring ps ⨃ singleton hk e)} + pure $ ps' {diffPsRetiring = insertD hk e} DCertDeleg _ -> do failBecause $ WrongCertificateTypePOOL 0 - pure ps + pure ps' DCertMir _ -> do failBecause $ WrongCertificateTypePOOL 1 - pure ps + pure ps' DCertGenesis _ -> do failBecause $ WrongCertificateTypePOOL 2 - pure ps + pure ps' diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs index 2e651e2b6ab..72bd7c142ae 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs @@ -87,7 +87,7 @@ import Generic.Random (genericArbitraryU) import Numeric.Natural (Natural) import Test.Cardano.Chain.UTxO.Gen (genCompactTxOut) import Test.Cardano.Ledger.Common -import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Cardano.Ledger.Core.Arbitrary (genDiffCoin, genDiffMonoidMap) import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) import Test.QuickCheck.Hedgehog (hedgehog) @@ -752,3 +752,25 @@ instance Arbitrary RawSeed where <*> chooseAny <*> chooseAny <*> chooseAny + +------------------------------------------------------------------------------------------ +-- Cardano.Ledger.Shelley ILC instances -------------------------------------------------- +------------------------------------------------------------------------------------------ + +instance (Era era, Arbitrary (PParamsHKD StrictMaybe era)) => Arbitrary (Diff (ShelleyPPUPState era)) where + arbitrary = ShelleyPPUPState' <$> arbitrary <*> arbitrary + +instance Crypto c => Arbitrary (Diff (IncrementalStake c)) where + arbitrary = IStake' <$> genDiffMonoidMap arbitrary genDiffCoin <*> genDiffMonoidMap arbitrary genDiffCoin + +instance + (Era era, Arbitrary (TxOut era), Arbitrary (Diff (GovernanceState era))) => + Arbitrary (Diff (UTxOState era)) + where + arbitrary = UTxOState' <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance + (Era era, Arbitrary (TxOut era), Arbitrary (Diff (GovernanceState era))) => + Arbitrary (Diff (LedgerState era)) + where + arbitrary = LedgerState' <$> arbitrary <*> arbitrary diff --git a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal index a10db3ade47..7b5d64caa61 100644 --- a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal +++ b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal @@ -22,6 +22,7 @@ source-repository head library exposed-modules: Test.Cardano.Ledger.TerseTools + Test.Cardano.Ledger.Shelley.ShelleyDiffTests Test.Cardano.Ledger.Shelley.Address.Bootstrap Test.Cardano.Ledger.Shelley.BenchmarkFunctions Test.Cardano.Ledger.Shelley.ByronTranslation @@ -79,7 +80,7 @@ library cardano-crypto-class, cardano-crypto-test, cardano-crypto-wrapper, - cardano-data, + cardano-data:{cardano-data, testlib}, cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.0, cardano-ledger-byron, cardano-ledger-byron-test, diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs index 9442b54a89d..cf67c41cf59 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs @@ -81,3 +81,14 @@ commonTests = , ByronTranslation.testGroupByronTranslation , ShelleyTranslation.testGroupShelleyTranslation ] + +-- ================================ +-- an example how one might debug one test, which can be replayed +-- import Test.Tasty (defaultMain) +-- import Cardano.Ledger.Crypto(StandardCrypto) +-- import Cardano.Ledger.Shelley(ShelleyEra) +-- main :: IO () +-- main = main = defaultMain (Pool.tests @(ShelleyEra StandardCrypto)) +-- Then in ghci, one can just type +-- :main --quickcheck-replay=443873 +-- ================================= diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs index 5d150a4be2e..ad48977194b 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -32,6 +32,7 @@ import Cardano.Protocol.TPraos.BHeader ( bheaderSlotNo, ) import Control.SetAlgebra (dom, eval, (∈), (∉)) +import Control.State.Transition (STS (State)) import Control.State.Transition.Trace ( SourceSignalTarget (..), TraceOrder (OldestFirst), @@ -97,9 +98,9 @@ poolRetirement :: Property poolRetirement SourceSignalTarget {source = chainSt, signal = block} = conjoin $ - map (poolRetirementProp currentEpoch maxEpoch) (sourceSignalTargets poolTr) + map (poolRetirementProp unDiff currentEpoch maxEpoch) (sourceSignalTargets poolTr) where - (chainSt', poolTr) = poolTraceFromBlock chainSt block + (chainSt', poolTr, unDiff) = poolTraceFromBlock chainSt block bhb = bhbody $ bheader block currentEpoch = (epochFromSlotNo . bheaderSlotNo) bhb maxEpoch = (view ppEMaxL . esPp . nesEs . chainNes) chainSt' @@ -116,9 +117,9 @@ poolRegistration :: Property poolRegistration (SourceSignalTarget {source = chainSt, signal = block}) = conjoin $ - map poolRegistrationProp (sourceSignalTargets poolTr) + map (poolRegistrationProp unDiff) (sourceSignalTargets poolTr) where - (_, poolTr) = poolTraceFromBlock chainSt block + (_, poolTr, unDiff) = poolTraceFromBlock chainSt block -- | Assert that PState maps are in sync with each other after each `Signal -- POOL` transition. @@ -132,49 +133,56 @@ poolStateIsInternallyConsistent :: Property poolStateIsInternallyConsistent (SourceSignalTarget {source = chainSt, signal = block}) = conjoin $ - map poolStateIsInternallyConsistentProp (traceStates OldestFirst poolTr) + map (poolStateIsInternallyConsistentProp . unDiff) (traceStates OldestFirst poolTr) where - (_, poolTr) = poolTraceFromBlock chainSt block + (_, poolTr, unDiff) = poolTraceFromBlock chainSt block -poolRegistrationProp :: SourceSignalTarget (ShelleyPOOL era) -> Property +poolRegistrationProp :: (State (ShelleyPOOL era) -> PState (EraCrypto era)) -> SourceSignalTarget (ShelleyPOOL era) -> Property poolRegistrationProp + unDiff SourceSignalTarget { signal = (DCertPool (RegPool poolParams)) , source = sourceSt , target = targetSt } = let hk = ppId poolParams - reRegistration = eval (hk ∈ dom (psStakePoolParams sourceSt)) + reRegistration = eval (hk ∈ dom (psStakePoolParams (unDiff sourceSt))) in if reRegistration then conjoin [ counterexample "Pre-existing PoolParams must still be registered in pParams" - (eval (hk ∈ dom (psStakePoolParams targetSt)) :: Bool) + (eval (hk ∈ dom (psStakePoolParams (unDiff targetSt))) :: Bool) , counterexample "New PoolParams are registered in future Params map" - (Map.lookup hk (psFutureStakePoolParams targetSt) === Just poolParams) + (Map.lookup hk (psFutureStakePoolParams (unDiff targetSt)) === Just poolParams) , counterexample "PoolParams are removed in 'retiring'" - (eval (hk ∉ dom (psRetiring targetSt)) :: Bool) + (eval (hk ∉ dom (psRetiring (unDiff targetSt))) :: Bool) ] else -- first registration conjoin [ counterexample "New PoolParams are registered in pParams" - (Map.lookup hk (psStakePoolParams targetSt) === Just poolParams) + (Map.lookup hk (psStakePoolParams (unDiff targetSt)) === Just poolParams) , counterexample "PoolParams are not present in 'future pool params'" - (eval (hk ∉ dom (psFutureStakePoolParams targetSt)) :: Bool) + (eval (hk ∉ dom (psFutureStakePoolParams (unDiff targetSt))) :: Bool) , counterexample "PoolParams are removed in 'retiring'" - (eval (hk ∉ dom (psRetiring targetSt)) :: Bool) + (eval (hk ∉ dom (psRetiring (unDiff targetSt))) :: Bool) ] -poolRegistrationProp _ = property () +poolRegistrationProp _ _ = property () -poolRetirementProp :: EpochNo -> EpochNo -> SourceSignalTarget (ShelleyPOOL era) -> Property +poolRetirementProp :: + (State (ShelleyPOOL era) -> PState (EraCrypto era)) -> + EpochNo -> + EpochNo -> + SourceSignalTarget (ShelleyPOOL era) -> + Property poolRetirementProp + unDiff currentEpoch@(EpochNo ce) (EpochNo maxEpoch) SourceSignalTarget {source = sourceSt, target = targetSt, signal = (DCertPool (RetirePool hk e))} = @@ -184,15 +192,15 @@ poolRetirementProp (currentEpoch < e && e < EpochNo (ce + maxEpoch)) , counterexample "hk must be in source stPools" - (eval (hk ∈ dom (psStakePoolParams sourceSt)) :: Bool) + (eval (hk ∈ dom (psStakePoolParams (unDiff sourceSt))) :: Bool) , counterexample "hk must be in target stPools" - (eval (hk ∈ dom (psStakePoolParams targetSt)) :: Bool) + (eval (hk ∈ dom (psStakePoolParams (unDiff targetSt))) :: Bool) , counterexample "hk must be in target's retiring" - (eval (hk ∈ dom (psRetiring targetSt)) :: Bool) + (eval (hk ∈ dom (psRetiring (unDiff targetSt))) :: Bool) ] -poolRetirementProp _ _ _ = property () +poolRetirementProp _ _ _ _ = property () poolStateIsInternallyConsistentProp :: PState c -> Property poolStateIsInternallyConsistentProp PState {psStakePoolParams = pParams_, psRetiring = retiring_} = do diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index 3af486df0b4..181321e5b0f 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -36,6 +36,7 @@ import Cardano.Ledger.Shelley.LedgerState ( EpochState (..), LedgerState (..), NewEpochState (..), + PState, UTxOState (..), ) import Cardano.Ledger.Shelley.Rules ( @@ -65,6 +66,7 @@ import Control.State.Transition.Trace.Generator.QuickCheck (forAllTraceFromInitS import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC import Data.Foldable (toList) import Data.Functor.Identity (Identity) +import Data.Incremental (ILC (..)) import qualified Data.Map.Strict as Map import Data.Proxy import qualified Data.Set as Set @@ -185,11 +187,11 @@ poolTraceFromBlock :: ) => ChainState era -> Block (BHeader (EraCrypto era)) era -> - (ChainState era, Trace (ShelleyPOOL era)) + (ChainState era, Trace (ShelleyPOOL era), State (ShelleyPOOL era) -> PState (EraCrypto era)) poolTraceFromBlock chainSt block = ( tickedChainSt - , runShelleyBase $ - Trace.closure @(ShelleyPOOL era) poolEnv poolSt0 poolCerts + , runShelleyBase $ Trace.closure @(ShelleyPOOL era) poolEnv (totalDiff poolSt0) poolCerts + , applyDiff poolSt0 ) where (tickedChainSt, ledgerEnv, ledgerSt0, txs) = ledgerTraceBase chainSt block @@ -197,7 +199,7 @@ poolTraceFromBlock chainSt block = poolCerts = filter poolCert (certs txs) poolEnv = let (LedgerEnv s _ pp _) = ledgerEnv - in PoolEnv s pp + in PoolEnv s pp poolSt0 poolSt0 = let LedgerState _ (DPState _ poolSt0_) = ledgerSt0 in poolSt0_ diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/ShelleyDiffTests.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/ShelleyDiffTests.hs new file mode 100644 index 00000000000..97954649bea --- /dev/null +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/ShelleyDiffTests.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Shelley.ShelleyDiffTests where + +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.LedgerState +import Test.Cardano.Data ( + propExtend, + propZero, + ) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Cardano.Ledger.Shelley.Arbitrary () + +-- ========================================================== + +-- We will have to tie these tests into the tests in +-- cardano-ledger/eras/shelley/testsuite/test/Tests.hs +-- The problem is this uses Tasty and the tests here use HSpec + +shelleyDiffTests :: Spec +shelleyDiffTests = describe "ILC Diff tests" $ do + describe "Diff IncrementalStake" $ do + propZero (arbitrary @(IncrementalStake StandardCrypto)) + propExtend (arbitrary @(IncrementalStake StandardCrypto)) arbitrary + describe "Diff UTxOState" $ do + propZero (arbitrary @(UTxOState (ShelleyEra StandardCrypto))) + propExtend (arbitrary @(UTxOState (ShelleyEra StandardCrypto))) arbitrary + describe "Diff LedgerState" $ do + propZero (arbitrary @(LedgerState (ShelleyEra StandardCrypto))) + propExtend (arbitrary @(LedgerState (ShelleyEra StandardCrypto))) arbitrary + +-- To run theses tests in ghci, uncomment and type 'main' +main :: IO () +main = hspec $ shelleyDiffTests diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/NetworkID.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/NetworkID.hs index cf881748829..d829e8391f4 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/NetworkID.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/NetworkID.hs @@ -21,6 +21,7 @@ import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Slot (SlotNo (..)) import Control.State.Transition.Extended hiding (Assertion) import Data.Default.Class (def) +import Data.Incremental (ILC (..)) import Lens.Micro import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C_Crypto) import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast @@ -49,8 +50,8 @@ testPoolNetworkID pv poolParams e = do runShelleyBase $ applySTSTest @(ShelleyPOOL ShelleyTest) ( TRC - ( PoolEnv (SlotNo 0) $ emptyPParams & ppProtocolVersionL .~ pv - , def + ( PoolEnv (SlotNo 0) (emptyPParams & ppProtocolVersionL .~ pv) def + , totalDiff def , DCertPool (RegPool poolParams) ) ) diff --git a/hie.yaml b/hie.yaml index 88b306de916..80a47475f30 100644 --- a/hie.yaml +++ b/hie.yaml @@ -69,6 +69,9 @@ cradle: - path: "eras/conway/impl/testlib" component: "cardano-ledger-conway:lib:testlib" + - path: "eras/conway/impl/test" + component: "cardano-ledger-conway:test:tests" + - path: "eras/conway/test-suite/src" component: "lib:cardano-ledger-conway-test" diff --git a/libs/cardano-data/cardano-data.cabal b/libs/cardano-data/cardano-data.cabal index 8e3ead5d72e..909ed3c0c0c 100644 --- a/libs/cardano-data/cardano-data.cabal +++ b/libs/cardano-data/cardano-data.cabal @@ -23,6 +23,7 @@ library Data.UMap Data.ListMap Data.Universe + Data.Incremental hs-source-dirs: src default-language: Haskell2010 @@ -54,6 +55,7 @@ library testlib build-depends: base, + cardano-data, containers, hspec, QuickCheck @@ -62,7 +64,10 @@ test-suite cardano-data-tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test - other-modules: Test.Cardano.Data.MapExtrasSpec + other-modules: + Test.Cardano.Data.MapExtrasSpec + Test.Cardano.Data.IlcTest + default-language: Haskell2010 ghc-options: -Wall -Wcompat -Wincomplete-record-updates diff --git a/libs/cardano-data/src/Data/Incremental.hs b/libs/cardano-data/src/Data/Incremental.hs new file mode 100644 index 00000000000..cd393e396a0 --- /dev/null +++ b/libs/cardano-data/src/Data/Incremental.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Introduce the Incremental Lambda Calculus embodied in the ILC class. +-- Instances for two patterns of use involving Maps. +module Data.Incremental where + +import Control.DeepSeq (NFData (..)) +import Data.Kind +import Data.Map.Internal (Map (..)) +import Data.Map.Strict +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import GHC.Generics (Generic (..)) + +-- =================================================== +-- Incremental lambda calculus + +class ILC t where + data Diff t :: Type + applyDiff :: t -> Diff t -> t + extend :: Diff t -> Diff t -> Diff t + zero :: Diff t + totalDiff :: t -> Diff t + +infixr 0 $$ +($$) :: ILC t => t -> Diff t -> t +x $$ y = applyDiff x y + +-- | Every (Diff t) is a Semigroup +instance ILC t => Semigroup (Diff t) where + x <> y = extend x y + +-- | Every (Diff t) is a Monoid +instance ILC t => Monoid (Diff t) where + mempty = zero + +-- ============================================================== +-- Delta types. +-- We are going to give the type (Map dom rng) an ILC instance. +-- It turns out there are two reasonable choices for Map. The two +-- reasonable choices differ on what properties the range of the Map +-- has. If the range of the Map is a monoid, there are 3 ways the map +-- might change. +-- 1) entry is deleted, +-- 2) an entry is changed or created, so there is a new range value +-- 3) the range of an entry is combined (using monoid (actually semigroup) <>) with another value. +-- +-- If the range is not a Monoid there are only two ways the map might change +-- 1) entry is deleted, +-- 2) an entry is changed or created, so there is a new range value +-- +-- To do this we introduce two datatypes MonoidRngD and BinaryRngD. They +-- will become part of the definition for the Diff(Map dom rng). It also +-- turns out thet Both of them are Semigroups (but not Monoids as neither +-- has a notion of No-Change. This is deliberate, but might be reconsidered +-- at some point) + +-- | The range is deleted, overwritten, or combined using a Monoid +data MonoidRngD v = DeleteM | WriteM !v | CombM !v + deriving (Show, Eq, Generic, NFData) + +instance (Semigroup t) => Semigroup (MonoidRngD t) where + CombM x <> DeleteM = WriteM x + CombM x <> WriteM y = WriteM (x <> y) + CombM x <> CombM y = CombM (x <> y) + x <> _ = x + +-- | The range is deleted or changed +data BinaryRngD v = DeleteD | WriteD !v + deriving (Eq, Generic, NFData) + +-- The show instance is manual because it supports cutting and pasting +-- error messages, to get values for exploring failures. With out the +-- parantheses they often won't read properly. +instance Show v => Show (BinaryRngD v) where + show DeleteD = "DeleteD" + show (WriteD d) = "WriteD(" ++ show d ++ ")" + +instance Semigroup (BinaryRngD t) where + DeleteD <> _ = DeleteD + WriteD x <> _ = WriteD x + +-- ============================================================ +-- Since there are two reasonable ILC instances for the Map +-- type we wrap the map in a newtype for the first instance. +-- This is the special case of a Map where the range is a +-- Monoid. We provide tools to enforce the invariant, that in a +-- MonoidMap, we never store 'mempty' of the Monoid. + +newtype MonoidMap k v = MM {unMM :: Map k v} + deriving newtype (Show, Eq, NFData) + +monoidInsertWith :: (Monoid v, Eq v, Ord k) => k -> v -> MonoidMap k v -> MonoidMap k v +monoidInsertWith k !v1 (MM m) = MM (alter ok k m) + where + ok Nothing = if v1 == mempty then Nothing else Just v1 + ok (Just v2) = if total == mempty then Nothing else Just total + where + total = v1 <> v2 +{-# INLINEABLE monoidInsertWith #-} + +monoidInsert :: (Monoid v, Eq v, Ord k) => k -> v -> MonoidMap k v -> MonoidMap k v +monoidInsert k !v1 (MM m) = if v1 == mempty then MM (delete k m) else MM (insert k v1 m) +{-# INLINEABLE monoidInsert #-} + +-- ========================================= +-- ILC instances + +-- | Monoidal maps have special properties, so they get their +-- own instance (wrapped in the newtype). +instance (Ord k, Eq v, ILC v, Monoid v) => ILC (MonoidMap k v) where + newtype Diff (MonoidMap k v) = Dm (Map k (MonoidRngD (Diff v))) + applyDiff mm (Dm md) = Map.foldlWithKey' accum mm md + where + accum :: MonoidMap k v -> k -> MonoidRngD (Diff v) -> MonoidMap k v + accum (MM ans) cred DeleteM = MM (Map.delete cred ans) + accum ans cred (CombM dv) = + monoidInsertWith cred (applyDiff mempty dv) ans + accum ans cred (WriteM dv) = monoidInsert cred (applyDiff mempty dv) ans + {-# INLINEABLE applyDiff #-} + zero = Dm Map.empty + extend (Dm x) (Dm y) = Dm (Map.unionWith (<>) x y) + totalDiff _ = zero + +instance (Show (Diff v), Show k) => Show (Diff (MonoidMap k v)) where + show (Dm x) = show (Map.toList x) + +deriving newtype instance (NFData k, NFData (Diff v)) => NFData (Diff (MonoidMap k v)) +deriving newtype instance (Eq k, Eq (Diff v)) => Eq (Diff (MonoidMap k v)) + +-- | Normal map can only be deleted or updated so they use BinaryRngD +instance Ord k => ILC (Map k v) where + newtype Diff (Map k v) = Dn (Map k (BinaryRngD v)) + deriving (Eq) + applyDiff m (Dn md) = Map.foldlWithKey' accum m md + where + accum ans k DeleteD = Map.delete k ans + accum ans k (WriteD drep) = Map.insert k drep ans + {-# INLINEABLE applyDiff #-} + zero = Dn Map.empty + extend (Dn x) (Dn y) = Dn (Map.unionWith (<>) x y) + totalDiff _ = zero + +instance (Show k, Show v) => Show (Diff (Map k v)) where + show (Dn x) = show (Map.toList x) + +deriving newtype instance (NFData k, NFData v) => NFData (Diff (Map k v)) + +-- =========================================================== +-- A type which is it's own diff (modulo no changes at all) + +newtype Total x = Total x + deriving (Eq, Show) + +instance ILC (Total x) where + data Diff (Total x) = Total' x | Zero + deriving (Eq, Show) + applyDiff (Total x) d = Total (applyTotal x d) + extend Zero x = x + extend x _ = x + zero = Zero + totalDiff (Total x) = Total' x + +applyTotal :: x -> Diff (Total x) -> x +applyTotal x Zero = x +applyTotal _ (Total' y) = y + +-- ================================================================ +-- Operations on Diff(MonoidMap k v) and Diff(Map k v) + +insertM :: k -> Diff v -> Diff (MonoidMap k v) +insertM k v = Dm (Map.singleton k (WriteM v)) + +deleteM :: k -> Diff (MonoidMap k v) +deleteM k = Dm (Map.singleton k DeleteM) + +combineM :: k -> Diff v -> Diff (MonoidMap k v) +combineM k v = Dm (Map.singleton k (CombM v)) + +lookupM :: (Monoid v, ILC v, Ord k) => k -> MonoidMap k v -> Diff (MonoidMap k v) -> Maybe v +lookupM k (MM m) (Dm dm) = case Map.lookup k dm of + Nothing -> Map.lookup k m + Just (WriteM x) -> Just (applyDiff mempty x) + Just DeleteM -> Nothing + Just (CombM x) -> case Map.lookup k m of + Nothing -> Just (applyDiff mempty x) + Just y -> Just (applyDiff y x) + +insertD :: k -> v -> Diff (Map k v) +insertD k v = Dn (Map.singleton k (WriteD v)) + +deleteD :: k -> Diff (Map k v) +deleteD k = Dn (Map.singleton k DeleteD) + +restrictDomainD :: Set k -> Diff (Map k v) +restrictDomainD = Dn . Map.fromSet (const DeleteD) + +lookupD :: Ord k => k -> Map k v -> Diff (Map k v) -> Maybe v +lookupD k m (Dn dm) = case Map.lookup k dm of + Nothing -> Map.lookup k m + Just (WriteD x) -> Just x + Just DeleteD -> Nothing + +-- ================================================================= +-- helper functions for making binary derivatives + +-- | insert a change (MonoidRngD c) into a Map. +-- Note that if we wrap the (result :: Map k (MonoidRngD c)) with the constructor 'Dn' +-- Dn :: Map k (BinaryRngD v) -> Diff (Map k v) +-- then we get Diff(Map k v) +insertC :: + (Ord k, Monoid c) => + k -> + MonoidRngD c -> + Map k (MonoidRngD c) -> + Map k (MonoidRngD c) +insertC = insertWith (<>) + +-- | Split two maps, x and y, into three parts +-- 1) the key appears only in x +-- 2) the key appears in both x and y +-- 3) the key appears only in y +-- Given three 'C'ontinuation style functions, reduce +-- the three parts to a single value. +inter3C :: + Ord k => + a -> + Map k u -> + Map k v -> + (a -> k -> u -> a) -> + (a -> k -> (u, v) -> a) -> + (a -> k -> v -> a) -> + a +inter3C ans0 m0 n0 c1 c2 c3 = go ans0 m0 n0 + where + go ans Tip Tip = ans + go !ans m Tip = Map.foldlWithKey' c1 ans m + go !ans Tip n = Map.foldlWithKey' c3 ans n + go !ans (Bin _ kx x l r) n = case Map.splitLookup kx n of + (ln, Nothing, rn) -> go (go (c1 ans kx x) l ln) r rn + (ln, Just y, rn) -> go (go (c2 ans kx (x, y)) l ln) r rn diff --git a/libs/cardano-data/test/Main.hs b/libs/cardano-data/test/Main.hs index ae18d769421..abed0ac23fb 100644 --- a/libs/cardano-data/test/Main.hs +++ b/libs/cardano-data/test/Main.hs @@ -7,6 +7,7 @@ import System.IO ( stdout, utf8, ) +import Test.Cardano.Data.IlcTest (ilcTests) import Test.Cardano.Data.MapExtrasSpec (mapExtrasSpec) import Test.Hspec import Test.Hspec.Runner @@ -22,6 +23,7 @@ spec :: Spec spec = describe "cardano-data" $ do describe "MapExtras" mapExtrasSpec + ilcTests main :: IO () main = do diff --git a/libs/cardano-data/test/Test/Cardano/Data/IlcTest.hs b/libs/cardano-data/test/Test/Cardano/Data/IlcTest.hs new file mode 100644 index 00000000000..b0c0dcd12e1 --- /dev/null +++ b/libs/cardano-data/test/Test/Cardano/Data/IlcTest.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Data.IlcTest (ilcTests) where + +import Data.Incremental +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Test.Cardano.Data (plusBinary, plusUnary, propExtend, propZero) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +-- ================================================================================== +-- These are standins for Coin and DRep which we can't import here + +newtype MockCoin = MockCoin Integer + deriving (Eq, Show, Ord) + +instance Semigroup MockCoin where + (MockCoin n) <> (MockCoin m) = MockCoin (n + m) + +instance Monoid MockCoin where + mempty = MockCoin 0 + +instance ILC MockCoin where + newtype Diff MockCoin = DeltaMockCoin Integer + deriving (Eq, Show) + applyDiff (MockCoin n) (DeltaMockCoin m) = MockCoin (n + m) + zero = DeltaMockCoin 0 + extend (DeltaMockCoin n) (DeltaMockCoin m) = DeltaMockCoin (n + m) + totalDiff _ = zero + +newtype Rep = Rep String + deriving (Eq, Ord, Show) + +instance Arbitrary Rep where + arbitrary = + Rep <$> do + a <- choose ('A', 'Z') + b <- choose ('a', 'z') + c <- choose ('0', '9') + pure [a, b, c] + +instance Arbitrary (Diff MockCoin) where + arbitrary = DeltaMockCoin <$> arbitrary + +instance Arbitrary MockCoin where + arbitrary = MockCoin <$> arbitrary + +-- ================================================================================== +-- derivative of a unary function + +sumCoins :: Map Int MockCoin -> MockCoin +sumCoins xs = Map.foldl' accum (MockCoin 0) xs + where + accum (MockCoin i) (MockCoin j) = MockCoin (i + j) + +sumCoins' :: Map Int MockCoin -> Diff (Map Int MockCoin) -> Diff MockCoin +sumCoins' m (Dn mb) = DeltaMockCoin $ Map.foldlWithKey' accum 0 mb + where + accum ans k DeleteD = case Map.lookup k m of + Nothing -> ans + Just (MockCoin i) -> ans - i + accum ans k (WriteD (MockCoin i)) = case Map.lookup k m of + Nothing -> ans + i + Just (MockCoin j) -> ans + i - j + +-- ================================================================================== +-- derivative of a binary function + +changeMockCoin :: MockCoin -> MockCoin -> MockCoin +changeMockCoin (MockCoin n) (MockCoin m) = MockCoin (m * n) + +changeCoin' :: MockCoin -> Diff MockCoin -> MockCoin -> Diff MockCoin -> Diff MockCoin +changeCoin' (MockCoin n) (DeltaMockCoin i) (MockCoin m) (DeltaMockCoin j) = + DeltaMockCoin (n * j + m * i + i * j) + +-- ================================================ + +insertDTest :: Int -> MockCoin -> Map Int MockCoin -> Expectation +insertDTest k v m = applyDiff m (insertD k v) `shouldBe` Map.insert k v m + +deleteDTest :: Int -> Map Int MockCoin -> Expectation +deleteDTest k m = applyDiff m (deleteD k) `shouldBe` Map.delete k m + +lookupDTest :: Int -> Map Int MockCoin -> Diff (Map Int MockCoin) -> Expectation +lookupDTest k m md = lookupD k m md `shouldBe` Map.lookup k (applyDiff m md) + +insertMTest :: Int -> Diff MockCoin -> Map Int MockCoin -> Expectation +insertMTest k v m = applyDiff (MM m) (insertM k v) `shouldBe` monoidInsert k (applyDiff mempty v) (MM m) + +deleteMTest :: Int -> Map Int MockCoin -> Expectation +deleteMTest k m = applyDiff (MM m) (deleteM k) `shouldBe` MM (Map.delete k m) + +combMTest :: Int -> Diff MockCoin -> Map Int MockCoin -> Expectation +combMTest k v m = applyDiff (MM m) (combineM k v) `shouldBe` monoidInsertWith k (applyDiff mempty v) (MM m) + +-- ================================================ +-- Property tests + +ilcTests :: Spec +ilcTests = describe "ILC tests" $ do + describe "Coin" $ do + propZero (arbitrary @MockCoin) + propExtend (arbitrary @MockCoin) (arbitrary @(Diff MockCoin)) + + describe "Map cred Coin" $ do + propZero (arbitrary @(Map Int MockCoin)) + propExtend (arbitrary @(Map Int MockCoin)) (arbitrary @(Diff (Map Int MockCoin))) + + describe "MonoidMap cred Coin" $ do + propZero (arbitrary @(MonoidMap Int MockCoin)) + propExtend (arbitrary @(MonoidMap Int MockCoin)) (arbitrary @(Diff (MonoidMap Int MockCoin))) + + describe "Map cred Rep" $ do + propZero (arbitrary @(Map Int Rep)) + propExtend (arbitrary @(Map Int Rep)) (arbitrary @(Diff (Map Int Rep))) + + describe "Total (Int,Bool)" $ do + propZero (arbitrary @(Total (Int, Bool))) + propExtend (arbitrary @(Total (Int, Bool))) (arbitrary @(Diff (Total (Int, Bool)))) + + describe "Unary functions" $ + prop "sumCoins' is derivative of unary function sumCoins" $ + plusUnary sumCoins sumCoins' + + describe "Binary functions" $ do + prop "changeCoin' is derivative of changeCoin" $ + plusBinary changeMockCoin changeCoin' arbitrary arbitrary arbitrary arbitrary + + describe "Functions on Diff(Map k v)" $ do + prop "insertD test" insertDTest + prop "deleteD test" deleteDTest + prop "lookupD test" lookupDTest + + describe "Functions on Diff(MonoidMap k v)" $ do + prop "insertM test" insertMTest + prop "deleteM test" deleteMTest + prop "combineM test" combMTest + +-- To run theses tests in ghci, uncomment and type 'main' +-- main = hspec $ ilcTests diff --git a/libs/cardano-data/testlib/Test/Cardano/Data.hs b/libs/cardano-data/testlib/Test/Cardano/Data.hs index 43d30d8f90b..d1f2a4019c2 100644 --- a/libs/cardano-data/testlib/Test/Cardano/Data.hs +++ b/libs/cardano-data/testlib/Test/Cardano/Data.hs @@ -1,12 +1,27 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Test.Cardano.Data ( expectValidMap, genNonEmptyMap, + propZero, + propExtend, + plusUnary, + plusBinary, + genMonoidRngD, + genBinaryRngD, ) where import Control.Monad +import Data.Incremental import qualified Data.Map.Internal.Debug as Map import qualified Data.Map.Strict as Map hiding (showTree) import Test.Hspec +import Test.Hspec.QuickCheck import Test.QuickCheck expectValidMap :: HasCallStack => (Ord k, Show k, Show a) => Map.Map k a -> Expectation @@ -23,3 +38,132 @@ expectValidMap m = genNonEmptyMap :: Ord k => Gen k -> Gen v -> Gen (Map.Map k v) genNonEmptyMap genKey genVal = Map.fromList <$> listOf1 ((,) <$> genKey <*> genVal) + +-- ====================================================================== +-- Reusable components for the Incremental Lambda Calculus (ILC) +-- ====================================================================== + +-- ================================= +-- Generic, reusable, Property tests + +propZero :: forall t. (Eq t, Show t, ILC t) => Gen t -> Spec +propZero gent = prop "propZero" $ do + x <- gent + pure $ applyDiff @t x (zero @t) `shouldBe` x + +type ILCProp t = (ILC t, Show t, Eq t, Show (Diff t)) + +propExtend :: forall t. (ILCProp t) => Gen t -> Gen (Diff t) -> Spec +propExtend gent genDiff = prop "propExtend" $ do + x <- gent + dx1 <- genDiff + dx2 <- genDiff + let ext = extend @t dx2 dx1 + appdif = applyDiff @t x dx1 + pure + ( counterexample + ( unlines + [ "x= " ++ show x + , "dx1= " ++ show dx1 + , "dx2= " ++ show dx2 + , "extend dx2 dx1= " ++ show ext + , "applyDiff x dx1= " ++ show appdif + , "lhs (applyDiff x (extend dx2 dx1))= " ++ show (applyDiff x ext) + , "rhs (applyDiff (applyDiff x dx1) dx2)= " ++ show (applyDiff appdif dx2) + ] + ) + (applyDiff x (extend @t dx2 dx1) `shouldBe` applyDiff (applyDiff @t x dx1) dx2) + ) + +-- | Test that f' is really the derivative of the unary function f. +plusUnary :: + forall a b. + (ILCProp a, ILCProp b) => + (a -> b) -> + (a -> Diff a -> Diff b) -> + a -> + Diff a -> + Property +plusUnary f f' a da = + counterexample + ( unlines + [ "a = " ++ show a + , "da = " ++ show da + , "f a = " ++ show (f a) + , "f' a da = " ++ show (f' a da) + , "applyDiff (f a) (f' a da)) = " ++ show (applyDiff (f a) (f' a da)) + , "applyDiff a da = " ++ show (applyDiff a da) + , "f (applyDiff a da) = " ++ show (f (applyDiff a da)) + ] + ) + (f (applyDiff a da) `shouldBe` applyDiff (f a) (f' a da)) + +-- | Test that f' is really the derivative of the binary function f. +plusBinary :: + forall a b c. + (ILCProp a, ILCProp b, ILCProp c) => + (a -> b -> c) -> + (a -> Diff a -> b -> Diff b -> Diff c) -> + Gen a -> + Gen (Diff a) -> + Gen b -> + Gen (Diff b) -> + Gen Property +plusBinary f f' ga gda gb gdb = do + m <- ga + dm <- gda + n <- gb + dn <- gdb + pure $ + counterexample + ( unlines + [ "m = " ++ show m + , "dm = " ++ show dm + , "n = " ++ show n + , "dn = " ++ show dn + , "f m n = " ++ show (f m n) + , "f' m dm n dn = " ++ show (f' m dm n dn) + , "applyDiff m dm = " ++ show (applyDiff m dm) + , "applyDiff n dn = " ++ show (applyDiff n dn) + , "" + , "f (applyDiff m dm) (applyDiff n dn) = " ++ show (f (applyDiff m dm) (applyDiff n dn)) + , "applyDiff (f m n) (f' m dm n dn) = " ++ show (applyDiff (f m n) (f' m dm n dn)) + ] + ) + (f (applyDiff m dm) (applyDiff n dn) `shouldBe` applyDiff (f m n) (f' m dm n dn)) + +-- ==================== +-- reusable ILC Generators + +instance Arbitrary t => Arbitrary (MonoidRngD t) where + arbitrary = genMonoidRngD arbitrary + +instance Arbitrary t => Arbitrary (BinaryRngD t) where + arbitrary = genBinaryRngD arbitrary + +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Diff (Map.Map k v)) where + arbitrary = Dn <$> arbitrary + +instance (Ord k, Eq v, Monoid v, Arbitrary k, Arbitrary v) => Arbitrary (MonoidMap k v) where + arbitrary = MM . Map.filter (/= mempty) <$> arbitrary + +instance (Ord k, Arbitrary (Diff v), Arbitrary k, Arbitrary v) => (Arbitrary (Diff (MonoidMap k v))) where + arbitrary = Dm <$> arbitrary + +genMonoidRngD :: Gen t -> Gen (MonoidRngD t) +genMonoidRngD g = oneof [pure DeleteM, WriteM <$> g, CombM <$> g] + +genBinaryRngD :: Gen t -> Gen (BinaryRngD t) +genBinaryRngD g = oneof [pure DeleteD, WriteD <$> g] + +genTotal :: Gen t -> Gen (Total t) +genTotal gent = Total <$> gent + +genDiffTotal :: Gen t -> Gen (Diff (Total t)) +genDiffTotal gent = frequency [(1, pure Zero), (6, Total' <$> gent)] + +instance Arbitrary t => Arbitrary (Total t) where + arbitrary = genTotal arbitrary + +instance Arbitrary t => Arbitrary (Diff (Total t)) where + arbitrary = genDiffTotal arbitrary diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 8218a10e974..b1b4bbca996 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -137,6 +137,7 @@ library testlib binary, bytestring, cardano-crypto-class, + cardano-data:{cardano-data, testlib}, cardano-ledger-core, cardano-ledger-binary:{cardano-ledger-binary, testlib}, cardano-ledger-byron-test, @@ -163,6 +164,7 @@ test-suite tests other-modules: Test.Cardano.Ledger.AddressSpec Test.Cardano.Ledger.BaseTypesSpec + Test.Cardano.Ledger.CoreDiffTests default-language: Haskell2010 ghc-options: @@ -175,6 +177,7 @@ test-suite tests aeson, binary, bytestring, + cardano-data:testlib, cardano-ledger-binary:{cardano-ledger-binary, testlib}, cardano-ledger-core, cardano-crypto-class, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs index 25118cf420c..b3ceb86a0d4 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs @@ -12,6 +12,7 @@ module Cardano.Ledger.Coin ( Coin (..), CompactForm (..), DeltaCoin (..), + Diff (DiffCoin), word64ToCoin, coinToRational, rationalToCoinViaFloor, @@ -41,6 +42,7 @@ import Cardano.Ledger.TreeDiff (ToExpr (toExpr)) import Control.DeepSeq (NFData) import Data.Aeson (FromJSON, ToJSON) import Data.Group (Abelian, Group (..)) +import Data.Incremental (ILC (..)) import Data.Monoid (Sum (..)) import Data.PartialOrd (PartialOrd) import Data.Primitive.Types @@ -150,3 +152,20 @@ decodePositiveCoin = do if n == 0 then fail "Expected a positive Coin. Got 0 (zero)." else pure $ Coin (toInteger n) + +-- =========================================== +-- Incremental Lambda Calculus instances + +-- The Diff of a Coin is Coin-like, except it can store negative values +-- We could use DeltaCoin, but we need newtype for the instance +instance ILC Coin where + {-# SPECIALIZE instance ILC Coin #-} + newtype Diff Coin = DiffCoin Integer + deriving newtype (Eq, Show, NFData) + applyDiff (Coin n) (DiffCoin m) = Coin (n + m) + zero = DiffCoin 0 + extend (DiffCoin n) (DiffCoin m) = DiffCoin (n + m) + totalDiff _ = zero + +-- {-# SPECIALIZE instance Semigroup (MonoidD Coin) #-} +-- {-# SPECIALIZE instance Semigroup (BinaryD Coin) #-} diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/DPState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/DPState.hs index 3c006f54d6a..062e9d2ee4c 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/DPState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/DPState.hs @@ -2,12 +2,11 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -25,6 +24,7 @@ module Cardano.Ledger.DPState ( payPoolDeposit, refundPoolDeposit, obligationDPState, + Diff (..), ) where @@ -44,6 +44,7 @@ import Cardano.Ledger.Binary ( import Cardano.Ledger.Coin ( Coin (..), DeltaCoin (..), + Diff (DiffCoin), ) import Cardano.Ledger.Compactible (fromCompact) import Cardano.Ledger.Core (EraCrypto, EraPParams, PParams, ppPoolDepositL) @@ -68,6 +69,7 @@ import Control.Monad.Trans import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=)) import Data.Default.Class (Default (def)) import Data.Foldable (foldl') +import Data.Incremental (ILC (..), MonoidMap (..), insertD, unMM, ($$)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import GHC.Generics (Generic) @@ -118,6 +120,26 @@ data InstantaneousRewards c = InstantaneousRewards } deriving (Show, Eq, Generic) +instance ILC (InstantaneousRewards c) where + data Diff (InstantaneousRewards c) = InstantaneousRewards' + { diffReserves :: !(Diff (MonoidMap (Credential 'Staking c) Coin)) + , diffTreasury :: !(Diff (MonoidMap (Credential 'Staking c) Coin)) + , diffDeltaReserves :: !(Diff Coin) + , diffDeltaTreasury :: !(Diff Coin) + } + deriving (Eq, Show) + applyDiff (InstantaneousRewards w x (DeltaCoin y) (DeltaCoin z)) (InstantaneousRewards' wd xd (DiffCoin yd) (DiffCoin zd)) = + InstantaneousRewards + (unMM (applyDiff (MM w) wd)) + (unMM (applyDiff (MM x) xd)) + (DeltaCoin (y + yd)) + (DeltaCoin (z + zd)) + zero = InstantaneousRewards' zero zero zero zero + extend (InstantaneousRewards' w x y z) (InstantaneousRewards' a b c d) = + InstantaneousRewards' (extend w a) (extend x b) (extend y c) (extend z d) + totalDiff (InstantaneousRewards w x (DeltaCoin y) (DeltaCoin z)) = + InstantaneousRewards' (totalDiff (MM w)) (totalDiff (MM x)) (totalDiff (Coin y)) (totalDiff (Coin z)) + instance NoThunks (InstantaneousRewards c) instance NFData (InstantaneousRewards c) @@ -150,6 +172,21 @@ data DState c = DState } deriving (Show, Eq, Generic) +instance ILC (DState c) where + data Diff (DState c) + = DState' + !(Diff (UMap c)) + !(Diff (Map (FutureGenDeleg c) (GenDelegPair c))) + !(Diff (Map (KeyHash 'Genesis c) (GenDelegPair c))) + !(Diff (InstantaneousRewards c)) + deriving (Eq, Show) + applyDiff (DState u f (GenDelegs g) i) (DState' ud fd gd iD) = + DState (u $$ ud) (f $$ fd) (GenDelegs (g $$ gd)) (i $$ iD) + zero = DState' zero zero zero zero + extend (DState' w x y z) (DState' a b c d) = DState' (extend w a) (extend x b) (extend y c) (extend z d) + totalDiff (DState w x (GenDelegs y) z) = + DState' (totalDiff w) (totalDiff x) (totalDiff y) (totalDiff z) + instance NoThunks (InstantaneousRewards c) => NoThunks (DState c) instance NFData (InstantaneousRewards c) => NFData (DState c) @@ -181,7 +218,7 @@ instance Crypto c => ToJSON (DState c) where toDStatePair :: (KeyValue a, Crypto c) => DState c -> [a] toDStatePair DState {..} = [ "unified" .= dsUnified - , "fGenDelegs" .= Map.toList (dsFutureGenDelegs) + , "fGenDelegs" .= Map.toList dsFutureGenDelegs , "genDelegs" .= dsGenDelegs , "irwd" .= dsIRewards ] @@ -219,6 +256,25 @@ data PState c = PState } deriving (Show, Eq, Generic) +instance ILC (PState c) where + data Diff (PState c) = PState' + { diffPsStakePoolParams :: !(Diff (Map (KeyHash 'StakePool c) (PoolParams c))) + , diffPsFutureStakePoolParams :: !(Diff (Map (KeyHash 'StakePool c) (PoolParams c))) + , diffPsRetiring :: !(Diff (Map (KeyHash 'StakePool c) EpochNo)) + , diffPsDeposits :: !(Diff (Map (KeyHash 'StakePool c) Coin)) + } + deriving (Eq, Show) + applyDiff (PState w x y z) (PState' wd xd yd zd) = + PState (w $$ wd) (x $$ xd) (y $$ yd) (z $$ zd) + zero = PState' zero zero zero zero + extend (PState' w x y z) (PState' a b c d) = + PState' (w `extend` a) (x `extend` b) (y `extend` c) (z `extend` d) + totalDiff (PState w x y z) = + PState' (totalDiff w) (totalDiff x) (totalDiff y) (totalDiff z) + +instance Default (Diff (PState c)) where + def = undefined + instance NoThunks (PState c) instance NFData (PState c) @@ -259,6 +315,15 @@ data DPState c = DPState } deriving (Show, Eq, Generic) +instance ILC (DPState c) where + data Diff (DPState c) = DPState' (Diff (DState c)) (Diff (PState c)) + deriving (Eq, Show) + applyDiff (DPState d p) (DPState' dD pD) = DPState (d $$ dD) (p $$ pD) + zero = DPState' zero zero + extend (DPState' x y) (DPState' a b) = DPState' (extend x a) (extend y b) + totalDiff (DPState w x) = + DPState' (totalDiff w) (totalDiff x) + instance NoThunks (InstantaneousRewards c) => NoThunks (DPState c) instance NFData (InstantaneousRewards c) => NFData (DPState c) @@ -341,13 +406,14 @@ payPoolDeposit :: KeyHash 'StakePool (EraCrypto era) -> PParams era -> PState (EraCrypto era) -> - PState (EraCrypto era) -payPoolDeposit keyhash pp pstate = pstate {psDeposits = newpool} + Diff (PState (EraCrypto era)) -> + Diff (PState (EraCrypto era)) +payPoolDeposit keyhash pp pstate pstate' = pstate' {diffPsDeposits = newpool <> diffPsDeposits pstate'} where - pool = psDeposits pstate + pool = psDeposits pstate $$ diffPsDeposits pstate' newpool - | Map.notMember keyhash pool = Map.insert keyhash (pp ^. ppPoolDepositL) pool - | otherwise = pool + | Map.notMember keyhash pool = insertD keyhash (pp ^. ppPoolDepositL) + | otherwise = zero refundPoolDeposit :: KeyHash 'StakePool c -> PState c -> (Coin, PState c) refundPoolDeposit keyhash pstate = (coin, pstate {psDeposits = newpool}) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs index d6056356bb3..4c9936f32ae 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs @@ -80,11 +80,13 @@ module Cardano.Ledger.UMapCompact ( size, unify, RDPair (..), + Diff (UMap', RDPair'), + Triple' (..), ) where import Cardano.Ledger.Binary -import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin)) +import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin), Diff (DiffCoin)) import Cardano.Ledger.Compactible (Compactible (..)) import Cardano.Ledger.Credential (Credential (..), Ptr) import Cardano.Ledger.Crypto (Crypto) @@ -110,6 +112,9 @@ import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..)) import Prelude hiding (lookup) +import Data.Incremental hiding (zero) +import qualified Data.Incremental as ILC + -- ================================================ -- A Reward-Deposit Pair, will be used to represent the reward @@ -818,3 +823,56 @@ instance ToExpr RDPair instance ToExpr (Trip c) instance ToExpr (UMap c) + +-- ============================================================================ + +-- pattern Triple :: StrictMaybe RDPair -> Set Ptr -> StrictMaybe (KeyHash 'StakePool c) -> Trip c + +-- | How the range of the UMap might change. Note we deliberately do NOT +-- include the (Set Ptr) as this is redundant information storing the +-- inverse of the Ptrs map. This will be changed when we make changes to the Ptrs map. +data Triple' c = Triple' (Diff RDPair) (BinaryRngD (KeyHash 'StakePool c)) + deriving (Eq, Show) + +instance Semigroup (Triple' c) where + (Triple' x y) <> (Triple' i j) = Triple' (x <> i) (y <> j) + +-- But. Note there is no Monoid instance for Triple', but that is OK + +instance ILC RDPair where + data Diff RDPair = RDPair' (Diff Coin) (Diff Coin) + deriving (Eq, Show) + applyDiff (RDPair (CompactCoin x) (CompactCoin y)) (RDPair' (DiffCoin i) (DiffCoin j)) = + (RDPair (CompactCoin (x + fromIntegral i)) (CompactCoin (y + fromIntegral j))) + zero = RDPair' (DiffCoin 0) (DiffCoin 0) + extend (RDPair' (DiffCoin x) (DiffCoin y)) (RDPair' (DiffCoin i) (DiffCoin j)) = + RDPair' (DiffCoin (x + i)) (DiffCoin (y + j)) + totalDiff _ = RDPair' (DiffCoin 0) (DiffCoin 0) + +instance Semigroup RDPair where + (RDPair x y) <> (RDPair a b) = RDPair (addCompact x a) (addCompact y b) +instance Monoid RDPair where + mempty = RDPair (CompactCoin 0) (CompactCoin 0) + +instance ILC (UMap c) where + data Diff (UMap c) + = UMap' + (Map (Credential 'Staking c) (Triple' c)) + (Map Ptr (BinaryRngD (Credential 'Staking c))) + deriving (Eq, Show) + applyDiff um0 (UMap' umD ptrmD) = Map.foldlWithKey' accumUm um1 umD + where + um1 = Map.foldlWithKey' accumPtr um0 ptrmD + accumPtr um2 ptr DeleteD = delete ptr (Ptrs um2) + accumPtr um2 ptr (WriteD v) = insert ptr v (Ptrs um2) + accumUm um3 cred (Triple' rd' ptr') = + case ptr' of + DeleteD -> delete cred (Delegations um4) + WriteD keyhash -> insert cred keyhash (Delegations um4) + where + um4 = case lookup cred (RewardDeposits um3) of + Just rd -> insert cred (applyDiff rd rd') (RewardDeposits um3) + Nothing -> insert cred (applyDiff mempty rd') (RewardDeposits um3) + zero = UMap' Map.empty Map.empty + extend (UMap' x y) (UMap' i j) = UMap' (Map.unionWith (<>) x i) (Map.unionWith (<>) y j) + totalDiff _ = UMap' Map.empty Map.empty diff --git a/libs/cardano-ledger-core/test/Main.hs b/libs/cardano-ledger-core/test/Main.hs index 13aae9f030d..a7ddf62337b 100644 --- a/libs/cardano-ledger-core/test/Main.hs +++ b/libs/cardano-ledger-core/test/Main.hs @@ -3,6 +3,7 @@ module Main where import qualified Test.Cardano.Ledger.AddressSpec as AddressSpec import qualified Test.Cardano.Ledger.BaseTypesSpec as BaseTypesSpec import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.CoreDiffTests (diffTests) main :: IO () main = @@ -10,3 +11,4 @@ main = describe "Core" $ do BaseTypesSpec.spec AddressSpec.spec + diffTests diff --git a/libs/cardano-ledger-core/test/Test/Cardano/Ledger/CoreDiffTests.hs b/libs/cardano-ledger-core/test/Test/Cardano/Ledger/CoreDiffTests.hs new file mode 100644 index 00000000000..84307af447f --- /dev/null +++ b/libs/cardano-ledger-core/test/Test/Cardano/Ledger/CoreDiffTests.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.CoreDiffTests (diffTests) where + +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.DPState ( + DPState (..), + DState (..), + InstantaneousRewards (..), + PState (..), + ) +import Cardano.Ledger.UMapCompact ( + RDPair, + UMap, + ) +import Test.Cardano.Data ( + propExtend, + propZero, + ) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Core.Arbitrary ( + genCoin, + genDiffCoin, + genDiffDPState, + genDiffDState, + genDiffInstantaneousRewards, + genDiffPState, + genDiffRDPair, + genDiffUMap, + ) + +-- ==================================================== + +diffTests :: Spec +diffTests = describe "ILC Diff tests" $ do + describe "Diff Coin" $ do + propZero genCoin + propExtend genCoin genDiffCoin + describe "Diff RDPair" $ do + propZero (arbitrary @RDPair) + propExtend arbitrary genDiffRDPair + describe "Diff UMap" $ do + propZero (arbitrary @(UMap StandardCrypto)) + propExtend (arbitrary @(UMap StandardCrypto)) genDiffUMap + describe "Diff InstantaneousRewards" $ do + propZero (arbitrary @(InstantaneousRewards StandardCrypto)) + propExtend (arbitrary @(InstantaneousRewards StandardCrypto)) genDiffInstantaneousRewards + describe "Diff PState" $ do + propZero (arbitrary @(PState StandardCrypto)) + propExtend (arbitrary @(PState StandardCrypto)) genDiffPState + describe "Diff DState" $ do + propZero (arbitrary @(DState StandardCrypto)) + propExtend (arbitrary @(DState StandardCrypto)) genDiffDState + describe "Diff DPState" $ do + propZero (arbitrary @(DPState StandardCrypto)) + propExtend (arbitrary @(DPState StandardCrypto)) genDiffDPState + +-- To run theses tests in ghci, uncomment and type 'main' +-- main :: IO () +-- main = hspec $ diffTests diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 672a3836010..95c807a1847 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -16,6 +16,16 @@ module Test.Cardano.Ledger.Core.Arbitrary ( genAddrBadPtr, genCompactAddrBadPtr, genBadPtr, + genCoin, + genDiffCoin, + genMonoidMap, + genDiffMonoidMap, + genDiffDState, + genDiffPState, + genDiffDPState, + genDiffInstantaneousRewards, + genDiffRDPair, + genDiffUMap, ) where @@ -76,10 +86,14 @@ import Cardano.Ledger.PoolParams ( ) import Cardano.Ledger.SafeHash (SafeHash, unsafeMakeSafeHash) import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) -import Cardano.Ledger.UMapCompact (RDPair (..), Trip (Triple), UMap (UMap)) +import Cardano.Ledger.UMapCompact (RDPair (..), Trip (Triple), Triple' (..), UMap (UMap)) import Cardano.Ledger.UTxO (UTxO (..)) import Control.Monad.Identity (Identity) import Data.GenValidity +import Data.Incremental ( + Diff (Dm, Dn), + MonoidMap (..), + ) import qualified Data.Map.Strict as Map import Data.Ratio ((%)) import qualified Data.Text as T @@ -89,6 +103,10 @@ import Data.Word (Word16, Word32, Word64) import GHC.Stack import Generic.Random (genericArbitraryU) import qualified Test.Cardano.Chain.Common.Gen as Byron +import Test.Cardano.Data ( + genBinaryRngD, + genMonoidRngD, + ) import Test.Cardano.Ledger.Binary.Arbitrary import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..)) import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) @@ -515,3 +533,77 @@ instance Crypto c => Arbitrary (Stake c) where let pair = (,) <$> arbitrary <*> (CompactCoin <$> genWord64 n) list <- frequency [(1, pure []), (99, vectorOf n pair)] pure (Map.fromList list) + +------------------------------------------------------------------------------------------ +-- Cardano.Ledger ILC instances ---------------------------------------------------------- +------------------------------------------------------------------------------------------ + +genCoin :: Gen Coin +genCoin = Coin <$> choose (100, 500) + +genDiffCoin :: Gen (Diff Coin) +genDiffCoin = DiffCoin <$> choose (-20, 20) + +genTriple' :: Crypto c => Gen (Triple' c) +genTriple' = Triple' <$> genDiffRDPair <*> genBinaryRngD arbitrary + +genDiffRDPair :: Gen (Diff RDPair) +genDiffRDPair = RDPair' <$> (DiffCoin <$> choose (-20, 20)) <*> (DiffCoin <$> choose (-20, 20)) + +genDiffUMap :: Crypto c => Gen (Diff (UMap c)) +genDiffUMap = + UMap' + <$> (Map.fromList <$> listOf ((,) <$> arbitrary <*> genTriple')) + <*> (Map.fromList <$> listOf ((,) <$> arbitrary <*> genBinaryRngD arbitrary)) + +genMonoidMap :: Ord k => Gen k -> Gen v -> Gen (MonoidMap k v) +genMonoidMap genk genv = (MM . Map.fromList) <$> listOf ((,) <$> genk <*> genv) + +genDiffMonoidMap :: Ord k => Gen k -> Gen (Diff v) -> Gen (Diff (MonoidMap k v)) +genDiffMonoidMap genk genvdiff = (Dm . Map.fromList) <$> listOf ((,) <$> genk <*> genMonoidRngD genvdiff) + +genDiffMap :: Ord k => Gen k -> Gen v -> Gen (Diff (Map.Map k v)) +genDiffMap genk genv = (Dn . Map.fromList) <$> listOf ((,) <$> genk <*> genBinaryRngD genv) + +genDiffInstantaneousRewards :: Crypto c => Gen (Diff (InstantaneousRewards c)) +genDiffInstantaneousRewards = + InstantaneousRewards' + <$> genDiffMonoidMap arbitrary genDiffCoin + <*> genDiffMonoidMap arbitrary genDiffCoin + <*> genDiffCoin + <*> genDiffCoin + +genDiffDState :: Crypto c => Gen (Diff (DState c)) +genDiffDState = + DState' + <$> genDiffUMap + <*> genDiffMap arbitrary arbitrary + <*> genDiffMap arbitrary arbitrary + <*> genDiffInstantaneousRewards + +genDiffPState :: Crypto c => Gen (Diff (PState c)) +genDiffPState = PState' <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +genDiffDPState :: Crypto c => Gen (Diff (DPState c)) +genDiffDPState = DPState' <$> genDiffDState <*> genDiffPState + +instance Crypto c => Arbitrary (Diff (DPState c)) where + arbitrary = genDiffDPState + +instance Crypto c => Arbitrary (Diff (PState c)) where + arbitrary = genDiffPState + +instance Crypto c => Arbitrary (Diff (DState c)) where + arbitrary = genDiffDState + +instance Crypto c => Arbitrary (Diff (InstantaneousRewards c)) where + arbitrary = genDiffInstantaneousRewards + +instance Crypto c => Arbitrary (Diff (UMap c)) where + arbitrary = genDiffUMap + +instance Arbitrary (Diff RDPair) where + arbitrary = genDiffRDPair + +instance Arbitrary (Diff Coin) where + arbitrary = genDiffCoin