Skip to content

Commit

Permalink
Added Data.Incremental with class(ILC) and basic instances (Map,Monoi…
Browse files Browse the repository at this point in the history
…dMap,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
  • Loading branch information
TimSheard committed Mar 31, 2023
1 parent c721b2a commit 25664e1
Show file tree
Hide file tree
Showing 33 changed files with 1,293 additions and 70 deletions.
20 changes: 20 additions & 0 deletions eras/conway/impl/cardano-ledger-conway.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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
71 changes: 69 additions & 2 deletions eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
Expand Down Expand Up @@ -37,6 +38,7 @@ module Cardano.Ledger.Conway.Governance (
GovernanceProcedure (..),
Anchor (..),
AnchorDataHash,
Diff (EnactState', RatifyState', ConwayGovernance'),
) where

import Cardano.Crypto.Hash.Class (hashToTextAsHex)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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})

Expand Down
10 changes: 10 additions & 0 deletions eras/conway/impl/test/Main.hs
Original file line number Diff line number Diff line change
@@ -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
31 changes: 31 additions & 0 deletions eras/conway/impl/test/Test/Cardano/Ledger/Conway/DiffSpec.hs
Original file line number Diff line number Diff line change
@@ -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
40 changes: 40 additions & 0 deletions eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
5 changes: 3 additions & 2 deletions eras/conway/test-suite/cardano-ledger-conway-test.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
1 change: 1 addition & 0 deletions eras/conway/test-suite/test/Tests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
30 changes: 29 additions & 1 deletion eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand All @@ -11,6 +13,7 @@
module Cardano.Ledger.Shelley.Governance (
EraGovernance (..),
ShelleyPPUPState (..),
Diff (ShelleyPPUPState'),
) where

import Cardano.Ledger.Binary (
Expand All @@ -23,13 +26,16 @@ import Cardano.Ledger.Binary (
import Cardano.Ledger.Binary.Coders (Decode (..), decode, (<!))
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates, emptyPPPUpdates)
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..), emptyPPPUpdates)
import Cardano.Ledger.TreeDiff (ToExpr)
import Control.DeepSeq (NFData)
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default.Class (Default (..))
import Data.Incremental (ILC (..), ($$))
import Data.Kind (Type)
import Data.Map (Map)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

Expand Down Expand Up @@ -72,6 +78,28 @@ data ShelleyPPUPState era = ShelleyPPUPState
}
deriving (Generic)

instance ILC (ShelleyPPUPState era) where
data Diff (ShelleyPPUPState era) = ShelleyPPUPState'
{ diffProposals :: !(Diff (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)))
, diffFutureProposals :: !(Diff (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)))
}
applyDiff ShelleyPPUPState {..} ShelleyPPUPState' {..} =
ShelleyPPUPState
{ proposals = ProposedPPUpdates (unProposedPPUpdates proposals $$ diffProposals)
, futureProposals = ProposedPPUpdates (unProposedPPUpdates futureProposals $$ diffProposals)
}
extend x y =
ShelleyPPUPState'
{ diffProposals = extend (diffProposals x) (diffProposals y)
, diffFutureProposals = extend (diffFutureProposals x) (diffFutureProposals y)
}
zero = ShelleyPPUPState' zero zero
totalDiff _ = ShelleyPPUPState' zero zero

deriving instance Show (PParamsUpdate era) => 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)
Expand Down
3 changes: 3 additions & 0 deletions eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs
Original file line number Diff line number Diff line change
Expand Up @@ -94,6 +94,9 @@ module Cardano.Ledger.Shelley.LedgerState (
lsUTxOStateL,
utxosFeesL,
utxosGovernanceL,

-- * ILC instances
Diff (IStake', UTxOState', LedgerState'),
) where

import Cardano.Ledger.DPState
Expand Down
Loading

0 comments on commit 25664e1

Please sign in to comment.