diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 553677c6f53..8efbc8d1dcb 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -213,6 +213,7 @@ jobs: - set-algebra - small-steps - vector-map + - ImpSpec ghc: ["8.10.7", "9.2.8", "9.6.6", "9.8.2", "9.10.1"] os: [ubuntu-latest] fail-fast: false diff --git a/.gitignore b/.gitignore index 29d80c16b02..4d01a201efb 100644 --- a/.gitignore +++ b/.gitignore @@ -24,7 +24,8 @@ **/*-blx.bib **/*.run.xml -## Cabal & Stack +## Cabal & Stack (we no longer use stack) +stack.yaml .stack-work*/ .stack-work-local/ */dist diff --git a/cabal.project b/cabal.project index fd3a95c36bd..614ebf1ecb9 100644 --- a/cabal.project +++ b/cabal.project @@ -69,6 +69,7 @@ packages: libs/cardano-data libs/set-algebra libs/vector-map + libs/ImpSpec -- == Byron era == -- byron-spec-chain: diff --git a/eras/allegra/impl/CHANGELOG.md b/eras/allegra/impl/CHANGELOG.md index e65fbd3b195..03bf706ea58 100644 --- a/eras/allegra/impl/CHANGELOG.md +++ b/eras/allegra/impl/CHANGELOG.md @@ -4,6 +4,10 @@ * Use `Mismatch` to clarify predicate failures. #4711 +### `testlib` + +* Switch to using `ImpSpec` package + ## 1.6.0.1 * diff --git a/eras/allegra/impl/cardano-ledger-allegra.cabal b/eras/allegra/impl/cardano-ledger-allegra.cabal index 43f66bf4f55..5fa3e1dc599 100644 --- a/eras/allegra/impl/cardano-ledger-allegra.cabal +++ b/eras/allegra/impl/cardano-ledger-allegra.cabal @@ -64,7 +64,7 @@ library bytestring, cardano-crypto-class, cardano-ledger-binary >=1.4, - cardano-ledger-core >=1.15 && <1.17, + cardano-ledger-core >=1.16 && <1.17, cardano-ledger-shelley ^>=1.15, cardano-strict-containers, cardano-slotting, diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs index 64e7106f0e0..98863c80def 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs @@ -10,7 +10,7 @@ module Test.Cardano.Ledger.Allegra.Imp (spec) where import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) import qualified Test.Cardano.Ledger.Allegra.Imp.UtxowSpec as UtxowSpec -import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Imp.Common import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp import Test.Cardano.Ledger.Shelley.ImpTest @@ -24,5 +24,5 @@ spec :: Spec spec = do ShelleyImp.spec @era - describe "AllegraImpSpec" . withImpState @era $ do + describe "AllegraImpSpec" . withImpInit @(LedgerSpec era) $ do UtxowSpec.spec diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp/UtxowSpec.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp/UtxowSpec.hs index c4851b8793b..5d658a4264a 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp/UtxowSpec.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp/UtxowSpec.hs @@ -29,7 +29,7 @@ spec :: ( ShelleyEraImp era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "UTXOW" $ do it "InvalidMetadata" $ do invalidMetadatum <- genInvalidMetadata diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 5a923c2df01..cbab8d3972e 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -14,6 +14,7 @@ ### `testlib` +* Switch to using `ImpSpec` package * Rename `expectPhase2Invalid` to `submitPhase2Invalid_` * Add `submitPhase2Invalid` * Add `expectTxSuccess` diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs index dd9efc453e1..7b8edca0350 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs @@ -17,8 +17,8 @@ import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFai import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec as Utxos import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow -import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, withImpState) -import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, LedgerSpec) +import Test.Cardano.Ledger.Imp.Common import qualified Test.Cardano.Ledger.Mary.Imp as MaryImp spec :: @@ -34,7 +34,7 @@ spec :: Spec spec = do MaryImp.spec @era - describe "AlonzoImpSpec" . withImpState @era $ do - Utxo.spec @era - Utxos.spec @era - Utxow.spec @era + describe "AlonzoImpSpec" . withImpInit @(LedgerSpec era) $ do + Utxo.spec + Utxos.spec + Utxow.spec diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs index 9c2b69f4ec9..edc055dec89 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs @@ -31,7 +31,7 @@ spec :: ( AlonzoEraImp era , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "UTXO" $ do it "Wrong network ID" $ do submitFailingTx diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs index cd6cc92ccab..a32b47d7f47 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs @@ -42,7 +42,7 @@ spec :: ( AlonzoEraImp era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "UTXOS" $ forM_ (eraLanguages @era) $ \lang -> withSLanguage lang $ \slang -> diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec.hs index d8dc6fcae03..21c9728d64c 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec.hs @@ -17,7 +17,7 @@ import Cardano.Ledger.Alonzo.Rules ( import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure) import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Invalid as Invalid import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Valid as Valid -import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, ImpTestState) +import Test.Cardano.Ledger.Alonzo.ImpTest import Test.Cardano.Ledger.Common spec :: @@ -27,8 +27,8 @@ spec :: , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do - describe "UTXOW PredicateFailures" $ do + describe "UTXOW" $ do Valid.spec Invalid.spec diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs index af9f5f28455..50d1fad59c9 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs @@ -57,7 +57,7 @@ spec :: , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "Invalid transactions" $ do it "Phase 1 script failure" $ do -- Script will be invalid because slot 100 will be in the future diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs index 0f4fccd567f..d764049f34a 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs @@ -28,7 +28,7 @@ spec :: ( AlonzoEraImp era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "Valid transactions" $ do forM_ (eraLanguages @era) $ \lang -> withSLanguage lang $ \slang -> diff --git a/eras/babbage/impl/CHANGELOG.md b/eras/babbage/impl/CHANGELOG.md index 91e6c69fb97..53303bbbf9e 100644 --- a/eras/babbage/impl/CHANGELOG.md +++ b/eras/babbage/impl/CHANGELOG.md @@ -4,6 +4,10 @@ * Use `Mismatch` to clarify predicate failures. #4711 +### `testlib` + +* Switch to using `ImpSpec` package + ## 1.10.0.0 * Add `ProtVer` argument to `TxInfo` functions: diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index 4807918bd12..39f3ccb13fd 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -77,7 +77,7 @@ library cardano-ledger-allegra ^>=1.6.1, cardano-ledger-alonzo >=1.12, cardano-ledger-binary >=1.4, - cardano-ledger-core >=1.15 && <1.17, + cardano-ledger-core >=1.16 && <1.17, cardano-ledger-mary ^>=1.7, cardano-ledger-shelley ^>=1.15, cardano-strict-containers, diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs index 4b9ea46e903..7c0a849c1fb 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs @@ -19,9 +19,9 @@ import Cardano.Ledger.Babbage.TxInfo (BabbageContextError) import Cardano.Ledger.BaseTypes (Inject) import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp -import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, withImpState) +import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, LedgerSpec) import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow -import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Imp.Common spec :: forall era. @@ -39,5 +39,5 @@ spec :: Spec spec = do AlonzoImp.spec @era - describe "BabbageImpSpec" . withImpState @era $ do - Utxow.spec @era + describe "BabbageImpSpec" . withImpInit @(LedgerSpec era) $ do + Utxow.spec diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxowSpec.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxowSpec.hs index 398ca4fc951..128ae869925 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxowSpec.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxowSpec.hs @@ -33,7 +33,7 @@ spec :: , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era , Inject (BabbageContextError era) (ContextError era) ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "UTXOW" $ do it "MalformedScriptWitnesses" $ do let scriptHash = hashPlutusScript (malformedPlutus @'PlutusV2) diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index db4064642f2..1d13cc1b940 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -8,6 +8,8 @@ ### `testlib` +* Switch to using `ImpSpec` package +* Remove `withImpStateWithProtVer` * Added `delegateSPORewardAddressToDRep_` * Add `mkUpdateCommitteeProposal` * Add `SubmitFailureExpectation`, `FailBoth`, `submitBootstrapAwareFailingVote`, `submitBootstrapAwareFailingProposal`, `submitBootstrapAwareFailingProposal_` diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs index c12c87fa6eb..b9fe1f2bf26 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs @@ -92,7 +92,7 @@ spec = describe "Regression" $ do , "49848004800504d9010281d8799f182aff0581840000d8799f182aff820000f4f6" ] describe "ImpTest" $ - withImpState @Conway $ + withImpInit @(LedgerSpec Conway) $ it "InsufficientCollateral is not encoded with negative coin #4198" $ do collateralAddress <- freshKeyAddr_ (_, skp) <- freshKeyPair diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs index 0aeac31caa3..749b5930c04 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs @@ -17,7 +17,6 @@ import Cardano.Ledger.Alonzo.Rules ( import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) import Cardano.Ledger.Babbage.TxInfo (BabbageContextError) import Cardano.Ledger.BaseTypes (Inject, ShelleyBase) -import Cardano.Ledger.Conway (Conway) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Rules ( ConwayBbodyPredFailure, @@ -44,7 +43,6 @@ import Control.State.Transition.Extended import Data.Sequence (Seq) import Data.Typeable (Typeable) import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp -import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.Imp.BbodySpec as Bbody import qualified Test.Cardano.Ledger.Conway.Imp.CertsSpec as Certs import qualified Test.Cardano.Ledger.Conway.Imp.DelegSpec as Deleg @@ -56,7 +54,8 @@ import qualified Test.Cardano.Ledger.Conway.Imp.LedgerSpec as Ledger import qualified Test.Cardano.Ledger.Conway.Imp.RatifySpec as Ratify import qualified Test.Cardano.Ledger.Conway.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Conway.Imp.UtxosSpec as Utxos -import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp, withImpStateWithProtVer) +import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp, LedgerSpec, modifyImpInitProtVer) +import Test.Cardano.Ledger.Imp.Common spec :: forall era. @@ -98,20 +97,18 @@ spec :: Spec spec = do BabbageImp.spec @era - let - conwayImpSpec protVer = + withImpInit @(LedgerSpec era) $ + forM_ (eraProtVersions @era) $ \protVer -> describe ("ConwayImpSpec - " <> show protVer) $ - withImpStateWithProtVer @era protVer $ do - describe "BBODY" $ Bbody.spec @era - describe "CERTS" $ Certs.spec @era - describe "DELEG" $ Deleg.spec @era - describe "ENACT" $ Enact.spec @era - describe "EPOCH" $ Epoch.spec @era - describe "GOV" $ Gov.spec @era - describe "GOVCERT" $ GovCert.spec @era - describe "LEDGER" $ Ledger.spec @era - describe "RATIFY" $ Ratify.spec @era - describe "UTXO" $ Utxo.spec @era - describe "UTXOS" $ Utxos.spec @era - in - forM_ [eraProtVerLow @Conway .. eraProtVerHigh @Conway] conwayImpSpec + modifyImpInitProtVer protVer $ do + describe "BBODY" Bbody.spec + describe "CERTS" Certs.spec + describe "DELEG" Deleg.spec + describe "ENACT" Enact.spec + describe "EPOCH" Epoch.spec + describe "GOV" Gov.spec + describe "GOVCERT" GovCert.spec + describe "LEDGER" Ledger.spec + describe "RATIFY" Ratify.spec + describe "UTXO" Utxo.spec + describe "UTXOS" Utxos.spec diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs index 8872e927567..e0e15323ddd 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs @@ -47,7 +47,7 @@ spec :: , EraSegWits era , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "BBODY" $ do it "BodyRefScriptsSizeTooBig" $ do Just (script :: Script era) <- pure largeScript diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs index 130b5bc98d7..d011bf7402b 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs @@ -28,7 +28,7 @@ spec :: , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do describe "Withdrawals" $ do it "Withdrawing from an unregistered reward account" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs index 2961462eb90..a47c8661258 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs @@ -41,7 +41,7 @@ spec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do describe "Register stake credential" $ do it "With correct deposit or without any deposit" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs index 09d45bd3a2f..512ed4b277f 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs @@ -55,7 +55,7 @@ spec :: , InjectRuleEvent "TICK" ConwayEpochEvent era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do committeeSpec treasuryWithdrawalsSpec @@ -74,7 +74,7 @@ treasuryWithdrawalsSpec :: , Eq (Event (EraRule "ENACT" era)) , Typeable (Event (EraRule "ENACT" era)) ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) treasuryWithdrawalsSpec = describe "Treasury withdrawals" $ do -- Treasury withdrawals are disallowed in bootstrap, so we're running these tests only post-bootstrap @@ -208,7 +208,7 @@ hardForkInitiationSpec :: , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era , InjectRuleEvent "TICK" ConwayEpochEvent era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) hardForkInitiationSpec = it "HardForkInitiation" $ whenPostBootstrap $ do committeeMembers' <- registerInitialCommittee @@ -256,7 +256,7 @@ hardForkInitiationNoDRepsSpec :: , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era , InjectRuleEvent "TICK" ConwayEpochEvent era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) hardForkInitiationNoDRepsSpec = it "HardForkInitiation without DRep voting" $ do committeeMembers' <- registerInitialCommittee @@ -285,7 +285,7 @@ hardForkInitiationNoDRepsSpec = ] getProtVer `shouldReturn` nextProtVer -pparamPredictionSpec :: ConwayEraImp era => SpecWith (ImpTestState era) +pparamPredictionSpec :: ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era)) pparamPredictionSpec = it "futurePParams" $ do committeeMembers' <- registerInitialCommittee @@ -306,7 +306,7 @@ pparamPredictionSpec = passEpoch getProtVer `shouldReturn` nextProtVer -noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpTestState era) +noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era)) noConfidenceSpec = it "NoConfidence" $ whenPostBootstrap $ do modifyPParams $ \pp -> @@ -355,7 +355,7 @@ constitutionSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) constitutionSpec = it "Constitution" $ do (committeeMember1 :| [committeeMember2]) <- registerInitialCommittee @@ -428,7 +428,7 @@ actionPrioritySpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) actionPrioritySpec = describe "Competing proposals" $ do it "higher action priority wins" $ do @@ -552,7 +552,7 @@ committeeSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) committeeSpec = describe "Committee enactment" $ do it "Enact UpdateCommitee with lengthy lifetime" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs index 19ae1051289..0d50aebe6c5 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs @@ -45,7 +45,7 @@ spec :: , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do dRepVotingSpec treasurySpec @@ -56,7 +56,7 @@ spec = do proposalsSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) proposalsSpec = describe "Proposals" $ do it "Proposals survive multiple epochs without any activity" $ do @@ -145,7 +145,7 @@ proposalsSpec = dRepSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) dRepSpec = describe "DRep" $ do it "expiry is updated based on the number of dormant epochs" $ do @@ -347,7 +347,7 @@ dRepSpec = dRepVotingSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) dRepVotingSpec = describe "DRep" $ do -- DRep voting for anything other than Info is disallowed during bootstrap, @@ -394,7 +394,7 @@ dRepVotingSpec = treasurySpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) treasurySpec = -- Treasury withdrawal are disallowed during bootstrap, -- so we can run tests that submit such proposal only post-bootstrap. @@ -487,7 +487,7 @@ eventsSpec :: , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) eventsSpec = describe "Events" $ do describe "emits event" $ do it "GovInfoEvent" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs index 0cc25ed7896..84034820c53 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs @@ -29,7 +29,7 @@ spec :: , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do it "Resigning proposed CC key" $ do ccColdCred <- KeyHashObj <$> freshKeyHash diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs index 2d5219d424a..2391e222905 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs @@ -46,7 +46,7 @@ spec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do constitutionSpec proposalsSpec @@ -64,7 +64,7 @@ spec = do unknownCostModelsSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) unknownCostModelsSpec = describe "Unknown CostModels" $ do it "Are accepted" $ do @@ -87,7 +87,7 @@ predicateFailuresSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) predicateFailuresSpec = describe "Predicate failures" $ do it "ProposalReturnAccountDoesNotExist" $ do @@ -163,7 +163,7 @@ hardForkSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) hardForkSpec = describe "HardFork" $ do describe "Hardfork is the first one (doesn't have a GovPurposeId) " $ do @@ -180,7 +180,7 @@ pparamUpdateSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) pparamUpdateSpec = describe "PParamUpdate" $ do describe "PPU needs to be wellformed" $ do @@ -245,7 +245,7 @@ proposalsSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) proposalsSpec = do describe "Proposals" $ do describe "Consistency" $ do @@ -753,7 +753,7 @@ votingSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) votingSpec = describe "Voting" $ do it "VotersDoNotExist" $ do @@ -889,7 +889,7 @@ constitutionSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) constitutionSpec = describe "Constitution proposals" $ do describe "accepted for" $ do @@ -972,7 +972,7 @@ policySpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) policySpec = describe "Policy" $ do it "policy is respected by proposals" $ whenPostBootstrap $ do @@ -1020,7 +1020,7 @@ networkIdSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) networkIdSpec = describe "Network ID" $ do it "Fails with invalid network ID in proposal return address" $ do @@ -1056,7 +1056,7 @@ withdrawalsSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) withdrawalsSpec = describe "Withdrawals" $ do it "Fails predicate when treasury withdrawal has nonexistent return address" $ do @@ -1254,7 +1254,7 @@ bootstrapPhaseSpec :: ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) bootstrapPhaseSpec = describe "Proposing and voting during bootstrap phase" $ do it "Parameter change" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs index 61d3fe8fa9e..3b7c15e5c7a 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs @@ -52,7 +52,7 @@ spec :: , STS (EraRule "LEDGERS" era) , ApplyTx era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do it "TxRefScriptsSizeTooBig" $ do -- we use here the largest script we currently have as many times as necessary to diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs index 903c0eee972..39e299747bb 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs @@ -37,7 +37,7 @@ import Test.Cardano.Ledger.Imp.Common spec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do votingSpec delayingActionsSpec @@ -69,7 +69,7 @@ spec = do initiateHardForkWithLessThanMinimalCommitteeSize :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) initiateHardForkWithLessThanMinimalCommitteeSize = it "Hard Fork can still be initiated with less than minimal committee size" $ do hotCs <- registerInitialCommittee @@ -97,7 +97,7 @@ initiateHardForkWithLessThanMinimalCommitteeSize = spoAndCCVotingSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spoAndCCVotingSpec = do describe "When CC expired" $ do let expireCommitteeMembers = do @@ -201,7 +201,7 @@ spoAndCCVotingSpec = do committeeExpiryResignationDiscountSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) committeeExpiryResignationDiscountSpec = -- Committee-update proposals are disallowed during bootstrap, so we can only run these tests post-bootstrap describe "Expired and resigned committee members are discounted from quorum" $ do @@ -273,7 +273,7 @@ committeeExpiryResignationDiscountSpec = paramChangeAffectsProposalsSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) paramChangeAffectsProposalsSpec = -- These tests rely on submitting committee-update proposals and on drep votes, which are disallowed during bootstrap, -- so we can only run them post-bootstrap @@ -446,7 +446,7 @@ paramChangeAffectsProposalsSpec = committeeMinSizeAffectsInFlightProposalsSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) committeeMinSizeAffectsInFlightProposalsSpec = -- Treasury withdrawals are disallowed during bootstrap, so we can only run these tests post-bootstrap describe "CommitteeMinSize affects in-flight proposals" $ do @@ -513,7 +513,7 @@ committeeMinSizeAffectsInFlightProposalsSpec = spoVotesForHardForkInitiation :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spoVotesForHardForkInitiation = describe "Counting of SPO votes" $ do it "HardForkInitiation" $ do @@ -542,7 +542,7 @@ spoVotesForHardForkInitiation = votingSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) votingSpec = describe "Voting" $ do -- These tests involve DRep voting, which is not possible in bootstrap, @@ -1450,7 +1450,7 @@ votingSpec = delayingActionsSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) delayingActionsSpec = -- All tests below are relying on submitting constitution of committe-update proposals, which are disallowed during bootstrap, -- so we can only run them post-bootstrap. @@ -1667,7 +1667,7 @@ delayingActionsSpec = committeeMaxTermLengthSpec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) committeeMaxTermLengthSpec = -- Committee-update proposals are disallowed during bootstrap, so we can only run these tests post-bootstrap describe "Committee members can serve full `CommitteeMaxTermLength`" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs index a4976c85010..68b587029c0 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs @@ -44,7 +44,7 @@ import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum) spec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "Reference scripts" $ do it "required reference script counts towards the minFee calculation" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs index 675c0c35da4..8713977f367 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs @@ -66,7 +66,7 @@ spec :: , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do govPolicySpec costModelsSpec @@ -95,7 +95,7 @@ datumAndReferenceInputsSpec :: , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era , ConwayEraImp era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) datumAndReferenceInputsSpec = do it "can use reference scripts" $ do producingTx <- setupRefTx @@ -205,7 +205,7 @@ conwayFeaturesPlutusV1V2FailureSpec :: , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era , Inject (ConwayContextError era) (ContextError era) ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) conwayFeaturesPlutusV1V2FailureSpec = do describe "Conway features fail in Plutusdescribe v1 and v2" $ do describe "Unsupported Fields" $ do @@ -450,7 +450,7 @@ govPolicySpec :: , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) govPolicySpec = do describe "Gov policy scripts" $ do -- These tests rely on the script in the constitution, but we can only change the constitution after bootstrap. @@ -534,7 +534,7 @@ costModelsSpec :: , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) costModelsSpec = -- These tests rely on the script in the constitution, but we can only change the constitution after bootstrap. -- So we cannot run these tests during bootstrap diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs index 87560f73483..4eba8f4d080 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -115,7 +115,6 @@ module Test.Cardano.Ledger.Conway.ImpTest ( cantFollow, getsPParams, currentProposalsShouldContain, - withImpStateWithProtVer, ifBootstrap, whenBootstrap, whenPostBootstrap, @@ -147,7 +146,6 @@ import Cardano.Ledger.BaseTypes ( ShelleyBase, StrictMaybe (..), UnitInterval, - Version, addEpochInterval, binOpEpochNo, hashAnchorData, @@ -263,23 +261,6 @@ conwayModifyPParams f = modifyNES $ \nes -> (snapshot, ratifyState) -> DRComplete snapshot (ratifyState & rsEnactStateL . ensCurPParamsL %~ f) -withImpStateWithProtVer :: - forall era. - ConwayEraImp era => - Version -> - SpecWith (ImpTestState era) -> - Spec -withImpStateWithProtVer ver = do - withImpStateModified $ - impNESL - . nesEsL - . esLStateL - . lsUTxOStateL - . utxosGovStateL - . cgsCurPParamsL - . ppProtocolVersionL - .~ ProtVer ver 0 - instance ( Crypto c , NFData (SigDSIGN (DSIGN c)) diff --git a/eras/mary/impl/CHANGELOG.md b/eras/mary/impl/CHANGELOG.md index 9e3c12f4b8f..879e265e2f9 100644 --- a/eras/mary/impl/CHANGELOG.md +++ b/eras/mary/impl/CHANGELOG.md @@ -1,9 +1,13 @@ # Version history for `cardano-ledger-mary` -## 1.7.0.2 +## 1.7.1.0 * +### `testlib` + +* Switch to using `ImpSpec` package + ## 1.7.0.1 * diff --git a/eras/mary/impl/cardano-ledger-mary.cabal b/eras/mary/impl/cardano-ledger-mary.cabal index 27ceb5b3c59..cb1a05781a6 100644 --- a/eras/mary/impl/cardano-ledger-mary.cabal +++ b/eras/mary/impl/cardano-ledger-mary.cabal @@ -73,7 +73,7 @@ library cardano-data ^>=1.2, cardano-ledger-allegra ^>=1.6.1, cardano-ledger-binary >=1.4, - cardano-ledger-core >=1.15 && <1.17, + cardano-ledger-core >=1.16 && <1.17, cardano-ledger-shelley ^>=1.15, containers, deepseq, diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs index 8d7156bbf08..5f5ccfa6292 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs @@ -11,10 +11,10 @@ import Cardano.Ledger.Allegra.Scripts import Cardano.Ledger.Mary.Core import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) import qualified Test.Cardano.Ledger.Allegra.Imp as AllegraImp -import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Imp.Common import qualified Test.Cardano.Ledger.Mary.Imp.UtxoSpec as Utxo import Test.Cardano.Ledger.Mary.ImpTest (MaryEraImp) -import Test.Cardano.Ledger.Shelley.ImpTest (withImpState) +import Test.Cardano.Ledger.Shelley.ImpTest (LedgerSpec) spec :: forall era. @@ -27,5 +27,5 @@ spec :: Spec spec = do AllegraImp.spec @era - describe "MaryImpSpec" $ withImpState @era $ do - Utxo.spec @era + describe "MaryImpSpec" $ withImpInit @(LedgerSpec era) $ do + Utxo.spec diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs index 309c63ee38a..19b17db3422 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs @@ -45,7 +45,7 @@ spec :: , AllegraEraScript era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "UTXO" $ do it "Mint a Token" $ void mintBasicToken describe "ShelleyUtxoPredFailure" $ do diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 54dc411d640..3c0de938578 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -35,6 +35,11 @@ ### `testlib` +* Switch to using `ImpSpec` package +* Remove: `runImpTestM`, `runImpTestM_`, `evalImpTestM`, `execImpTestM`, `runImpTestGenM`, `runImpTestGenM_`, `evalImpTestGenM`, `execImpTestGenM`, `withImpState` and `withImpStateModified`. +* Add `LedgerSpec`, `modifyImpInitProtVer`. +* Re-export `ImpM` and `ImpInit` +* Remove `iteState` and `iteQuickCheckSize` from `ImpTestEnv` * Added `ToExpr` instance for `ShelleyLedgersEnv` * Changed type signature of `freshKeyHashVRF` to return `VRFVerKeyHash` instead of just a `Hash` * Added `expectUTxOContent` diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index e7d889c8ea1..1ffea744259 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/eras/shelley/impl/cardano-ledger-shelley.cabal @@ -166,11 +166,9 @@ library testlib FailT, generic-random, hedgehog-quickcheck, - hspec-core, - HUnit, + ImpSpec, prettyprinter, prettyprinter-ansi-terminal, - QuickCheck, random, small-steps >=1.1, text, diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs index a651a78a926..f61a2586ff3 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs @@ -8,12 +8,12 @@ module Test.Cardano.Ledger.Shelley.Imp (spec) where import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) -import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Imp.Common import qualified Test.Cardano.Ledger.Shelley.Imp.EpochSpec as Epoch import qualified Test.Cardano.Ledger.Shelley.Imp.LedgerSpec as Ledger import qualified Test.Cardano.Ledger.Shelley.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Shelley.Imp.UtxowSpec as Utxow -import Test.Cardano.Ledger.Shelley.ImpTest (ShelleyEraImp, withImpState) +import Test.Cardano.Ledger.Shelley.ImpTest (LedgerSpec, ShelleyEraImp) import qualified Test.Cardano.Ledger.Shelley.UnitTests.IncrementalStakeTest as Incremental spec :: @@ -25,10 +25,10 @@ spec :: ) => Spec spec = do - describe "ShelleyImpSpec" $ withImpState @era $ do - Ledger.spec @era - Epoch.spec @era - Utxow.spec @era - Utxo.spec @era + describe "ShelleyImpSpec" $ withImpInit @(LedgerSpec era) $ do + Ledger.spec + Epoch.spec + Utxow.spec + Utxo.spec describe "ShelleyPureTests" $ do Incremental.spec @era diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs index 3c6f4608b11..b8e7d0faab0 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs @@ -23,7 +23,7 @@ import Test.Cardano.Ledger.Shelley.ImpTest spec :: forall era. ShelleyEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "EPOCH" $ do it "Runs basic transaction" $ do do diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs index bfc35917898..d3c435f4ec6 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs @@ -21,7 +21,7 @@ import Test.Cardano.Ledger.Shelley.ImpTest spec :: forall era. ShelleyEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "LEDGER" $ do it "Transactions update UTxO" $ do kpPayment1 <- lookupKeyPair =<< freshKeyHash diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs index 11d7b074c25..3cb8287f27d 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs @@ -20,7 +20,7 @@ spec :: ( ShelleyEraImp era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "UTXO" $ do describe "ShelleyUtxoPredFailure" $ do it "ValueNotConservedUTxO" $ do diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs index cfecdffcd52..5fb1c057adc 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs @@ -33,7 +33,7 @@ spec :: , Arbitrary (TxAuxData era) , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = describe "UTXOW" $ do describe "Bootstrap Witness" $ do it "Valid Witnesses" $ do diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index b9f060bd5b3..0faa667932c 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -25,15 +25,8 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( ImpTestM, + LedgerSpec, SomeSTSEvent (..), - runImpTestM, - runImpTestM_, - evalImpTestM, - execImpTestM, - runImpTestGenM, - runImpTestGenM_, - evalImpTestGenM, - execImpTestGenM, ImpTestState, ImpTestEnv (..), ImpException (..), @@ -84,8 +77,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( registerPoolWithRewardAccount, registerAndRetirePoolToMakeReward, getRewardAccountAmount, - withImpState, - withImpStateModified, shelleyFixupTx, lookupImpRootTxOut, sendValueTo, @@ -107,6 +98,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( defaultInitImpTestState, impEraStartEpochNo, impSetSeed, + modifyImpInitProtVer, -- * Logging Doc, @@ -132,6 +124,10 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impNativeScriptsG, produceScript, advanceToPointOfNoReturn, + + -- * ImpSpec re-exports + ImpM, + ImpInit, ) where import qualified Cardano.Chain.Common as Byron @@ -234,7 +230,7 @@ import Cardano.Slotting.Time (mkSlotLength) import Control.Monad (forM) import Control.Monad.IO.Class import Control.Monad.Reader (MonadReader (..), asks) -import Control.Monad.State.Strict (MonadState (..), StateT, evalStateT, gets, modify) +import Control.Monad.State.Strict (MonadState (..), evalStateT, gets, modify) import Control.Monad.Trans.Fail.String (errorFail) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Writer.Class (MonadWriter (..)) @@ -252,39 +248,26 @@ import Data.Default (Default (..)) import Data.Foldable (toList, traverse_) import Data.Functor (($>)) import Data.Functor.Identity (Identity (..)) -import Data.IORef import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Maybe (catMaybes, mapMaybe) import Data.Sequence.Strict (StrictSeq (..)) import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T import Data.Time.Format.ISO8601 (iso8601ParseM) import Data.TreeDiff (ansiWlExpr) import Data.Type.Equality (TestEquality (..)) import Data.Void -import GHC.Stack (CallStack, SrcLoc (..), getCallStack) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Lens.Micro (Lens', SimpleGetter, lens, to, (%~), (&), (.~), (<>~), (^.)) import Lens.Micro.Mtl (use, view, (%=), (+=), (.=)) import Numeric.Natural (Natural) -import Prettyprinter ( - Doc, - Pretty (..), - annotate, - hcat, - indent, - line, - vsep, - ) -import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color) -import System.Random -import qualified System.Random as Random +import Prettyprinter (Doc) +import Prettyprinter.Render.Terminal (AnsiStyle) +import qualified System.Random.Stateful as R import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation) -import Test.Cardano.Ledger.Binary.TreeDiff (srcLocToLocation) import Test.Cardano.Ledger.Core.Arbitrary () import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraExpectation) import Test.Cardano.Ledger.Core.KeyPair ( @@ -299,26 +282,35 @@ import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Plutus (PlutusArgs, ScriptTestContext) import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..)) import Test.Cardano.Slotting.Numeric () -import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..)) -import Test.Hspec.Core.Spec ( - Example (..), - Params, - Result (..), - paramsQuickCheckArgs, - ) -import qualified Test.Hspec.Core.Spec as H -import Test.QuickCheck.Gen (Gen (..)) -import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen) +import Test.ImpSpec import Type.Reflection (Typeable, typeOf) -import UnliftIO (MonadUnliftIO (..)) -import UnliftIO.Exception ( - Exception (..), - SomeException (..), - catchAny, - catchAnyDeep, - evaluateDeep, - throwIO, - ) +import UnliftIO.Exception (evaluateDeep) + +type ImpTestM era = ImpM (LedgerSpec era) + +data LedgerSpec era + +instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where + type ImpSpecEnv (LedgerSpec era) = ImpTestEnv era + type ImpSpecState (LedgerSpec era) = ImpTestState era + impInitIO qcGen = do + ioGen <- R.newIOGenM qcGen + initState <- evalStateT (runReaderT initImpTestState ioGen) (mempty :: ImpPrepState (EraCrypto era)) + pure $ + ImpInit + { impInitEnv = + ImpTestEnv + { iteFixup = fixupTx + , iteCborRoundTripFailures = True + } + , impInitState = initState + } + + -- There is an important step here of running TICK rule. This is necessary as a final + -- step of `era` initialization, because on the very first TICK of an era the + -- `futurePParams` are applied and the epoch number is updated to the first epoch + -- number of the current era + impPrepAction = passTick data SomeSTSEvent era = forall (rule :: Symbol). @@ -344,8 +336,6 @@ data ImpTestState era = ImpTestState , impNativeScripts :: !(Map (ScriptHash (EraCrypto era)) (NativeScript era)) , impLastTick :: !SlotNo , impGlobals :: !Globals - , impLog :: !(Doc AnsiStyle) - , impGen :: !QCGen , impEvents :: [SomeSTSEvent era] } @@ -353,13 +343,21 @@ data ImpTestState era = ImpTestState data ImpPrepState c = ImpPrepState { impPrepKeyPairs :: !(Map (KeyHash 'Witness c) (KeyPair 'Witness c)) , impPrepByronKeyPairs :: !(Map (BootstrapAddress c) ByronKeyPair) - , impPrepGen :: !QCGen } -instance HasSubState (ImpPrepState era) where - type SubState (ImpPrepState era) = StateGen QCGen - getSubState = StateGen . impPrepGen - setSubState s (StateGen g) = s {impPrepGen = g} +instance Semigroup (ImpPrepState c) where + (<>) ips1 ips2 = + ImpPrepState + { impPrepKeyPairs = impPrepKeyPairs ips1 <> impPrepKeyPairs ips2 + , impPrepByronKeyPairs = impPrepByronKeyPairs ips1 <> impPrepByronKeyPairs ips2 + } + +instance Monoid (ImpPrepState c) where + mempty = + ImpPrepState + { impPrepKeyPairs = mempty + , impPrepByronKeyPairs = mempty + } class Crypto c => HasKeyPairs t c | t -> c where keyPairsL :: Lens' t (Map (KeyHash 'Witness c) (KeyPair 'Witness c)) @@ -373,15 +371,9 @@ instance Crypto c => HasKeyPairs (ImpPrepState c) c where keyPairsL = lens impPrepKeyPairs (\x y -> x {impPrepKeyPairs = y}) keyPairsByronL = lens impPrepByronKeyPairs (\x y -> x {impPrepByronKeyPairs = y}) -instance Monad m => HasStatefulGen (StateGenM (ImpPrepState era)) (StateT (ImpPrepState era) m) where - askStatefulGen = pure StateGenM - impGlobalsL :: Lens' (ImpTestState era) Globals impGlobalsL = lens impGlobals (\x y -> x {impGlobals = y}) -impLogL :: Lens' (ImpTestState era) (Doc AnsiStyle) -impLogL = lens impLog (\x y -> x {impLog = y}) - impNESL :: Lens' (ImpTestState era) (NewEpochState era) impNESL = lens impNES (\x y -> x {impNES = y}) @@ -482,7 +474,7 @@ class ShelleyEraImp era where initGenesis :: - (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen (StateGenM s) m, MonadFail m) => + (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen g m, MonadFail m) => m (Genesis era) default initGenesis :: (Monad m, Genesis era ~ NoGenesis era) => @@ -490,12 +482,12 @@ class initGenesis = pure NoGenesis initNewEpochState :: - (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen (StateGenM s) m, MonadFail m) => + (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen g m, MonadFail m) => m (NewEpochState era) default initNewEpochState :: ( HasKeyPairs s (EraCrypto era) , MonadState s m - , HasStatefulGen (StateGenM s) m + , HasStatefulGen g m , MonadFail m , ShelleyEraImp (PreviousEra era) , TranslateEra era NewEpochState @@ -509,9 +501,7 @@ class initImpTestState :: ( HasKeyPairs s (EraCrypto era) , MonadState s m - , HasSubState s - , SubState s ~ StateGen QCGen - , HasStatefulGen (StateGenM s) m + , HasStatefulGen g m , MonadFail m ) => m (ImpTestState era) @@ -536,10 +526,10 @@ class fixupTx :: HasCallStack => Tx era -> ImpTestM era (Tx era) defaultInitNewEpochState :: - forall era s m. + forall era g s m. ( MonadState s m , HasKeyPairs s (EraCrypto era) - , HasStatefulGen (StateGenM s) m + , HasStatefulGen g m , MonadFail m , ShelleyEraImp era , ShelleyEraImp (PreviousEra era) @@ -574,17 +564,15 @@ impEraStartEpochNo = EpochNo (getVersion majProtVer * 100) majProtVer = eraProtVerLow @era defaultInitImpTestState :: - forall era s m. + forall era s g m. ( EraGov era , EraTxOut era , DSIGN (EraCrypto era) ~ Ed25519DSIGN , ADDRHASH (EraCrypto era) ~ Blake2b_224 , HasKeyPairs s (EraCrypto era) , MonadState s m - , HasStatefulGen (StateGenM s) m + , HasStatefulGen g m , MonadFail m - , HasSubState s - , SubState s ~ StateGen QCGen ) => NewEpochState era -> m (ImpTestState era) @@ -602,8 +590,7 @@ defaultInitImpTestState nes = do nesWithRoot = nes & nesEsL . esLStateL . lsUTxOStateL . utxosUtxoL <>~ UTxO (Map.singleton rootTxIn rootTxOut) prepState <- get - let StateGen qcGen = getSubState prepState - epochInfoE = + let epochInfoE = fixedEpochInfo (sgEpochLength shelleyGenesis) (mkSlotLength . fromNominalDiffTimeMicro $ sgSlotLength shelleyGenesis) @@ -619,11 +606,27 @@ defaultInitImpTestState nes = do , impNativeScripts = mempty , impLastTick = slotNo , impGlobals = globals - , impLog = mempty - , impGen = qcGen , impEvents = mempty } +modifyImpInitProtVer :: + forall era. + ShelleyEraImp era => + Version -> + SpecWith (ImpInit (LedgerSpec era)) -> + SpecWith (ImpInit (LedgerSpec era)) +modifyImpInitProtVer ver = + modifyImpInit $ \impInit -> + impInit + { impInitState = + impInitState impInit + & impNESL + . nesEsL + . curPParamsEpochStateL + . ppProtocolVersionL + .~ ProtVer ver 0 + } + impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era) impLedgerEnv nes = do slotNo <- gets impLastTick @@ -761,9 +764,7 @@ impWitsVKeyNeeded txBody = do pure (bootAddrs, allKeyHashes Set.\\ bootKeyHashes) data ImpTestEnv era = ImpTestEnv - { iteState :: !(IORef (ImpTestState era)) - , iteFixup :: Tx era -> ImpTestM era (Tx era) - , iteQuickCheckSize :: !Int + { iteFixup :: Tx era -> ImpTestM era (Tx era) , iteCborRoundTripFailures :: !Bool -- ^ Expect failures in CBOR round trip serialization tests for predicate failures } @@ -774,22 +775,6 @@ iteFixupL = lens iteFixup (\x y -> x {iteFixup = y}) iteCborRoundTripFailuresL :: Lens' (ImpTestEnv era) Bool iteCborRoundTripFailuresL = lens iteCborRoundTripFailures (\x y -> x {iteCborRoundTripFailures = y}) -newtype ImpTestM era a = ImpTestM {unImpTestM :: ReaderT (ImpTestEnv era) IO a} - deriving - ( Functor - , Applicative - , Monad - , MonadIO - , MonadUnliftIO - , MonadReader (ImpTestEnv era) - ) - -instance (Testable a, ShelleyEraImp era) => Testable (ImpTestM era a) where - property m = property $ MkGen $ \qcGen qcSize -> - ioProperty $ do - impTestState <- evalStateT initImpTestState (emptyImpPrepState @(EraCrypto era) (Just qcGen)) - evalImpTestM (Just qcSize) impTestState m - instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where writer (x, evs) = (impEventsL %= (<> evs)) $> x listen act = do @@ -803,204 +788,6 @@ instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where ((a, f), evs) <- listen act writer (a, f evs) -instance MonadFail (ImpTestM era) where - fail = assertFailure - -instance MonadState (ImpTestState era) (ImpTestM era) where - get = ImpTestM $ do - liftIO . readIORef . iteState =<< ask - put x = ImpTestM $ do - liftIO . flip writeIORef x . iteState =<< ask - -instance (ShelleyEraImp era, Testable prop) => Example (ImpTestM era prop) where - type Arg (ImpTestM era prop) = ImpTestState era - - evaluateExample impTest = - evaluateExample (\() -> impTest) - -instance (ShelleyEraImp era, Arbitrary a, Show a, Testable prop) => Example (a -> ImpTestM era prop) where - type Arg (a -> ImpTestM era prop) = ImpTestState era - - evaluateExample impTest params hook progressCallback = - let runImpTestExample s = property $ \x -> do - let args = paramsQuickCheckArgs params - (r, testable, logs) <- uncurry evalImpTestM (applyParamsQCGen params s) $ do - t <- impTest x - qcSize <- asks iteQuickCheckSize - StateGen qcGen <- subStateM split - logs <- gets impLog - pure (Just (qcGen, qcSize), t, logs) - let params' = params {paramsQuickCheckArgs = args {replay = r, chatty = False}} - res <- - evaluateExample - (counterexample (ansiDocToString logs) testable) - params' - (\f -> hook (\_st -> f ())) - progressCallback - void $ throwIO $ resultStatus res - in evaluateExample runImpTestExample params hook progressCallback - -instance MonadGen (ImpTestM era) where - liftGen (MkGen f) = do - qcSize <- asks iteQuickCheckSize - StateGen qcGen <- subStateM split - pure $ f qcGen qcSize - variant n action = do - subStateM (\(StateGen qcGen) -> ((), StateGen (integerVariant (toInteger n) qcGen))) - action - sized f = do - qcSize <- asks iteQuickCheckSize - f qcSize - resize n = local (\env -> env {iteQuickCheckSize = n}) - choose r = subStateM (Random.randomR r) - -instance HasStatefulGen (StateGenM (ImpTestState era)) (ImpTestM era) where - askStatefulGen = pure StateGenM - -instance HasSubState (ImpTestState era) where - type SubState (ImpTestState era) = StateGen QCGen - getSubState = StateGen . impGen - setSubState s (StateGen g) = s {impGen = g} - --- | Override the QuickCheck generator using a fixed seed. -impSetSeed :: Int -> ImpTestM era () -impSetSeed seed = setSubStateM $ StateGen $ mkQCGen seed - -applyParamsQCGen :: Params -> ImpTestState era -> (Maybe Int, ImpTestState era) -applyParamsQCGen params impTestState = - case replay (paramsQuickCheckArgs params) of - Nothing -> (Nothing, impTestState) - Just (qcGen, qcSize) -> (Just qcSize, mixinCurrentGen impTestState qcGen) - --- | Instead of reqplacing the current QC generator in the state, we use the current and --- the supplied to make the new generator -mixinCurrentGen :: ImpTestState era -> QCGen -> ImpTestState era -mixinCurrentGen impTestState qcGen = - impTestState {impGen = integerVariant (fst (Random.random (impGen impTestState))) qcGen} - -evalImpTestGenM :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO b) -evalImpTestGenM impState = fmap (fmap fst) . runImpTestGenM impState - -evalImpTestM :: - ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b -evalImpTestM qc impState = fmap fst . runImpTestM qc impState - -execImpTestGenM :: - ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (ImpTestState era)) -execImpTestGenM impState = fmap (fmap snd) . runImpTestGenM impState - -emptyImpPrepState :: Maybe QCGen -> ImpPrepState c -emptyImpPrepState mQCGen = - ImpPrepState - { impPrepKeyPairs = mempty - , impPrepByronKeyPairs = mempty - , impPrepGen = fromMaybe (mkQCGen 2024) mQCGen - } - -execImpTestM :: - ShelleyEraImp era => - Maybe Int -> - ImpTestState era -> - ImpTestM era b -> - IO (ImpTestState era) -execImpTestM qcSize impState = fmap snd . runImpTestM qcSize impState - -runImpTestGenM_ :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO ()) -runImpTestGenM_ impState = fmap void . runImpTestGenM impState - -runImpTestM_ :: - ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO () -runImpTestM_ qcSize impState = void . runImpTestM qcSize impState - -runImpTestGenM :: - ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (b, ImpTestState era)) -runImpTestGenM impState m = - MkGen $ \qcGen qcSz -> runImpTestM (Just qcSz) (mixinCurrentGen impState qcGen) m - -runImpTestM :: - ShelleyEraImp era => - Maybe Int -> - ImpTestState era -> - ImpTestM era b -> - IO (b, ImpTestState era) -runImpTestM mQCSize impState action = do - let qcSize = fromMaybe 30 mQCSize - ioRef <- newIORef impState - let - env = - ImpTestEnv - { iteState = ioRef - , iteFixup = fixupTx - , iteQuickCheckSize = qcSize - , iteCborRoundTripFailures = True - } - res <- - -- There is an important step here of running TICK rule. This is necessary as a final - -- step of `era` initialization, because on the very first TICK of an era the - -- `futurePParams` are applied and the epoch number is updated to the first epoch - -- number of the current era - runReaderT (unImpTestM (passTick >> action)) env `catchAny` \exc -> do - logs <- impLog <$> readIORef ioRef - let x my = case my of - Nothing -> x - Just y -> x ++ [pretty y] - uncaughtException header excThrown = - H.ColorizedReason $ - ansiDocToString $ - vsep $ - header ++ [pretty $ "Uncaught Exception: " <> displayException excThrown] - fromHUnitFailure header (HUnitFailure mSrcLoc failReason) = - case failReason of - Reason msg -> - H.Failure (srcLocToLocation <$> mSrcLoc) $ - H.ColorizedReason $ - ansiDocToString $ - vsep $ - header ++ [annotate (color Red) (pretty msg)] - ExpectedButGot mMsg expected got -> - H.Failure (srcLocToLocation <$> mSrcLoc) $ - H.ExpectedButGot (Just (ansiDocToString $ vsep (header mMsg))) expected got - adjustFailureReason header = \case - H.Failure mLoc failureReason -> - H.Failure mLoc $ - case failureReason of - H.NoReason -> - H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) "NoReason"] - H.Reason msg -> - H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) (pretty msg)] - H.ColorizedReason msg -> - H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [pretty msg] - H.ExpectedButGot mPreface expected actual -> - H.ExpectedButGot (Just (ansiDocToString $ vsep (header mPreface))) expected actual - H.Error mInfo excThrown -> uncaughtException (header mInfo) excThrown - result -> result - newExc - | Just hUnitExc <- fromException exc = fromHUnitFailure [logs] hUnitExc - | Just hspecFailure <- fromException exc = adjustFailureReason [logs] hspecFailure - | Just (ImpException ann excThrown) <- fromException exc = - let annLen = length ann - header = - logs - : [ let prefix - | annLen <= 1 = "╺╸" - | n <= 0 = "┏╸" - | n + 1 == annLen = indent (n - 1) "┗━╸" - | otherwise = indent (n - 1) "┗┳╸" - in annotate (color Red) prefix <> annotate (color Yellow) a - | (n, a) <- zip [0 ..] ann - ] - ++ [""] - in case fromException excThrown of - Just hUnitExc -> fromHUnitFailure header hUnitExc - Nothing -> - case fromException excThrown of - Just hspecFailure -> adjustFailureReason header hspecFailure - Nothing -> H.Failure Nothing $ uncaughtException header excThrown - | otherwise = H.Failure Nothing $ uncaughtException [logs] exc - throwIO newExc - endState <- readIORef ioRef - pure (res, endState) - runShelleyBase :: ShelleyBase a -> ImpTestM era a runShelleyBase act = do globals <- use impGlobalsL @@ -1450,75 +1237,6 @@ passNEpochsChecking :: passNEpochsChecking n checks = replicateM_ (fromIntegral n) $ passEpoch >> checks --- | Stores extra information about the failure of the unit test -data ImpException = ImpException - { ieAnnotation :: [Doc AnsiStyle] - -- ^ Description of the IO action that caused the failure - , ieThrownException :: SomeException - -- ^ Exception that caused the test to fail - } - deriving (Show) - -instance Exception ImpException where - displayException = ansiDocToString . prettyImpException - -prettyImpException :: ImpException -> Doc AnsiStyle -prettyImpException (ImpException ann e) = - vsep $ - mconcat - [ ["Annotations:"] - , zipWith indent [0, 2 ..] ann - , ["Failed with Exception:", indent 4 $ pretty (displayException e)] - ] - --- | Annotation for when failure happens. All the logging done within annotation will be --- discarded if there no failures within the annotation. -impAnn :: NFData a => String -> ImpTestM era a -> ImpTestM era a -impAnn msg = impAnnDoc (pretty msg) - -impAnnDoc :: NFData a => Doc AnsiStyle -> ImpTestM era a -> ImpTestM era a -impAnnDoc msg m = do - logs <- use impLogL - res <- catchAnyDeep m $ \exc -> - throwIO $ - case fromException exc of - Just (ImpException ann origExc) -> ImpException (msg : ann) origExc - Nothing -> ImpException [msg] exc - impLogL .= logs - pure res - --- | Adds a source location and Doc to the log, which are only shown if the test fails -logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpTestM era () -logWithCallStack callStack entry = impLogL %= (<> stack <> line <> indent 2 entry <> line) - where - prettySrcLoc' SrcLoc {..} = - hcat - [ annotate (color c) d - | (c, d) <- - [ (Yellow, "[") - , (Blue, pretty srcLocModule) - , (Yellow, ":") - , (Magenta, pretty srcLocStartLine) - , (Yellow, "]") - ] - ] - prefix n = if n <= 0 then "" else indent (n - 1) "└" - stack = - vsep - [prefix n <> prettySrcLoc' loc | (n, (_, loc)) <- zip [0, 2 ..] . reverse $ getCallStack callStack] - --- | Adds a Doc to the log, which is only shown if the test fails -logDoc :: HasCallStack => Doc AnsiStyle -> ImpTestM era () -logDoc = logWithCallStack ?callStack - --- | Adds a Text to the log, which is only shown if the test fails -logText :: HasCallStack => Text -> ImpTestM era () -logText = logWithCallStack ?callStack . pretty - --- | Adds a String to the log, which is only shown if the test fails -logString :: HasCallStack => String -> ImpTestM era () -logString = logWithCallStack ?callStack . pretty - -- | Adds a ToExpr to the log, which is only shown if the test fails logToExpr :: (HasCallStack, ToExpr a) => a -> ImpTestM era () logToExpr = logWithCallStack ?callStack . ansiWlExpr . toExpr @@ -1530,21 +1248,6 @@ impLogToExpr action = do logWithCallStack ?callStack . ansiWlExpr . toExpr $ e pure e -withImpState :: - ShelleyEraImp era => - SpecWith (ImpTestState era) -> - Spec -withImpState = withImpStateModified id - -withImpStateModified :: - forall era. - ShelleyEraImp era => - (ImpTestState era -> ImpTestState era) -> - SpecWith (ImpTestState era) -> - Spec -withImpStateModified f = - beforeAll (f <$> evalStateT initImpTestState (emptyImpPrepState @(EraCrypto era) Nothing)) - -- | Creates a fresh @SafeHash@ freshSafeHash :: Era era => ImpTestM era (SafeHash (EraCrypto era) a) freshSafeHash = arbitrary @@ -1584,13 +1287,13 @@ lookupKeyPair keyHash = do -- ImpTestState. If you also need the `KeyPair` consider using `freshKeyPair` for -- generation or `lookupKeyPair` to look up the `KeyPair` corresponding to the `KeyHash` freshKeyHash :: - (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => + (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) => m (KeyHash r c) freshKeyHash = fst <$> freshKeyPair -- | Generate a random `KeyPair` and add it to the known keys in the Imp state freshKeyPair :: - (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => + (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) => m (KeyHash r c, KeyPair r c) freshKeyPair = do keyPair <- uniformM @@ -1600,13 +1303,13 @@ freshKeyPair = do -- | Generate a random `Addr` that uses a `KeyHash`, and add the corresponding `KeyPair` -- to the known keys in the Imp state. freshKeyAddr_ :: - (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => m (Addr c) + (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) => m (Addr c) freshKeyAddr_ = snd <$> freshKeyAddr -- | Generate a random `Addr` that uses a `KeyHash`, add the corresponding `KeyPair` -- to the known keys in the Imp state, and return the `KeyHash` as well as the `Addr`. freshKeyAddr :: - (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => + (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) => m (KeyHash r c, Addr c) freshKeyAddr = do keyHash <- freshKeyHash @@ -1632,12 +1335,12 @@ lookupByronKeyPair bootAddr = do -- ImpTestState. If you also need the `ByronKeyPair` consider using `freshByronKeyPair` for -- generation or `lookupByronKeyPair` to look up the `ByronKeyPair` corresponding to the `KeyHash` freshByronKeyHash :: - (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => + (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) => m (KeyHash r c) freshByronKeyHash = coerceKeyRole . bootstrapKeyHash <$> freshBootstapAddress freshBootstapAddress :: - (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => + (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) => m (BootstrapAddress c) freshBootstapAddress = do keyPair@(ByronKeyPair verificationKey _) <- uniformM diff --git a/hie.yaml b/hie.yaml index 6d9fd7d996c..08034031a9f 100644 --- a/hie.yaml +++ b/hie.yaml @@ -174,6 +174,12 @@ cradle: - path: "eras/shelley-ma/test-suite/test" component: "cardano-ledger-shelley-ma-test:test:cardano-ledger-shelley-ma-test" + - path: "libs/ImpSpec/src" + component: "lib:ImpSpec" + + - path: "libs/ImpSpec/test" + component: "ImpSpec:test:tests" + - path: "libs/cardano-data/src" component: "lib:cardano-data" diff --git a/libs/ImpSpec/CHANGELOG.md b/libs/ImpSpec/CHANGELOG.md new file mode 100644 index 00000000000..2e062d91441 --- /dev/null +++ b/libs/ImpSpec/CHANGELOG.md @@ -0,0 +1,5 @@ +# Version history for `ImpSpec` + +## 0.1.0.0 + +* diff --git a/libs/ImpSpec/ImpSpec.cabal b/libs/ImpSpec/ImpSpec.cabal new file mode 100644 index 00000000000..5f18cec5d7c --- /dev/null +++ b/libs/ImpSpec/ImpSpec.cabal @@ -0,0 +1,65 @@ +cabal-version: 3.0 +name: ImpSpec +version: 0.1.0.0 +license: Apache-2.0 +maintainer: operations@iohk.io +author: IOHK +homepage: https://github.com/intersectmbo/cardano-ledger +synopsis: + Imperative approach of testing that extends HSpec and QuickCheck + +category: Control +build-type: Simple +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/intersectmbo/cardano-ledger + subdir: libs/ImpSpec + +library + exposed-modules: + Test.ImpSpec + Test.ImpSpec.Expectations + Test.ImpSpec.Expectations.Lifted + Test.ImpSpec.Main + Test.ImpSpec.Random + + hs-source-dirs: src + other-modules: Test.ImpSpec.Internal + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages + + build-depends: + base >=4.14 && <5, + bytestring, + deepseq, + hspec, + hspec-core, + hspec-expectations-lifted, + HUnit, + mtl, + QuickCheck, + quickcheck-transformer, + prettyprinter, + prettyprinter-ansi-terminal, + random, + text, + unliftio + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: Test.Suite.ImpSpec + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages + -threaded -rtsopts + + build-depends: + base, + ImpSpec diff --git a/libs/ImpSpec/Setup.hs b/libs/ImpSpec/Setup.hs new file mode 100644 index 00000000000..e8ef27dbba9 --- /dev/null +++ b/libs/ImpSpec/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/libs/ImpSpec/src/Test/ImpSpec.hs b/libs/ImpSpec/src/Test/ImpSpec.hs new file mode 100644 index 00000000000..9630fcbe4db --- /dev/null +++ b/libs/ImpSpec/src/Test/ImpSpec.hs @@ -0,0 +1,8 @@ +module Test.ImpSpec (module X) where + +import Test.Hspec as X (Spec, SpecWith, describe, fdescribe, fit, it, xdescribe, xit) +import Test.Hspec.QuickCheck as X (fprop, prop, xprop) +import Test.ImpSpec.Expectations.Lifted as X +import Test.ImpSpec.Internal as X +import Test.ImpSpec.Main as X +import Test.ImpSpec.Random as X diff --git a/libs/ImpSpec/src/Test/ImpSpec/Expectations.hs b/libs/ImpSpec/src/Test/ImpSpec/Expectations.hs new file mode 100644 index 00000000000..144e3a694d1 --- /dev/null +++ b/libs/ImpSpec/src/Test/ImpSpec/Expectations.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE ImplicitParams #-} + +module Test.ImpSpec.Expectations ( + -- * Expectations + + -- ** Common + assertBool, + assertFailure, + expectationFailure, + shouldBe, + shouldSatisfy, + shouldStartWith, + shouldEndWith, + shouldContain, + shouldMatchList, + shouldReturn, + shouldNotBe, + shouldNotSatisfy, + shouldNotContain, + shouldNotReturn, + shouldThrow, + Selector, + + -- ** Custom + assertColorFailure, + + -- *** Either + shouldBeRight, + shouldBeLeft, + expectRight, + expectRightDeep, + expectRightDeep_, + expectLeft, + expectLeftDeep, + expectLeftDeep_, + + -- *** Maybe + shouldBeJust, + expectJust, + expectJustDeep, + expectJustDeep_, + expectNothing, + + -- * CallStack helpers + callStackToLocation, + srcLocToLocation, +) where + +import Control.DeepSeq (NFData) +import Control.Monad (void, (>=>)) +import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack) +import Test.HUnit.Base (assertBool, assertFailure) +import Test.Hspec ( + Expectation, + Selector, + expectationFailure, + shouldBe, + shouldContain, + shouldEndWith, + shouldMatchList, + shouldNotBe, + shouldNotContain, + shouldNotReturn, + shouldNotSatisfy, + shouldReturn, + shouldSatisfy, + shouldStartWith, + shouldThrow, + ) +import Test.Hspec.Core.Spec (FailureReason (ColorizedReason), Location (..), ResultStatus (Failure)) +import UnliftIO.Exception (evaluateDeep, throwIO) + +infix 1 `shouldBeRight` + , `shouldBeLeft` + +-- | Similar to `assertFailure`, except hspec will not interfer with any escape sequences +-- that indicate color output. +assertColorFailure :: HasCallStack => String -> IO a +assertColorFailure msg = + throwIO $ Failure (callStackToLocation ?callStack) (ColorizedReason msg) + +-- | Return value on the `Right` and fail otherwise. +-- +-- Difference from @`shouldSatisfy` action `Data.Either.isRight`@ in that `expectRight` +-- will force the content of the `Right` to WHNF and return it. This expectation will also +-- show the content of the `Left` when expectation fails. +expectRight :: (HasCallStack, Show a) => Either a b -> IO b +expectRight (Right r) = pure $! r +expectRight (Left l) = assertFailure $ "Expected Right, got Left:\n" <> show l + +-- | Same as `expectRight`, but also evaluate the returned value to NF +expectRightDeep :: (HasCallStack, Show a, NFData b) => Either a b -> IO b +expectRightDeep = expectRight >=> evaluateDeep + +-- | Same as `expectRightDeep`, but discards the result +expectRightDeep_ :: (HasCallStack, Show a, NFData b) => Either a b -> IO () +expectRightDeep_ = void . expectRightDeep + +-- | Same as `shouldBe`, except it checks that the value is `Right` +shouldBeRight :: (HasCallStack, Show a, Show b, Eq b) => Either a b -> b -> Expectation +shouldBeRight e x = expectRight e >>= (`shouldBe` x) + +-- | Return value on the `Left` an fail otherwise +-- +-- Difference from @`shouldSatisfy` action `Data.Either.isLeft`@ in that `expectLeft` will +-- force the content of the `Left` to WHNF and and return it. This expectation will also +-- show the content of the `Right` when expectation fails. +expectLeft :: (HasCallStack, Show b) => Either a b -> IO a +expectLeft (Left l) = pure $! l +expectLeft (Right r) = assertFailure $ "Expected Left, got Right:\n" <> show r + +-- | Same as `expectLeft`, but also evaluate the returned value to NF +expectLeftDeep :: (HasCallStack, NFData a, Show b) => Either a b -> IO a +expectLeftDeep = expectLeft >=> evaluateDeep + +-- | Same as `expectLeftDeep`, but discards the result +expectLeftDeep_ :: (HasCallStack, NFData a, Show b) => Either a b -> IO () +expectLeftDeep_ = void . expectLeftDeep + +-- | Same as `shouldBe`, except it checks that the value is `Left` +shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b) => Either a b -> a -> Expectation +shouldBeLeft e x = expectLeft e >>= (`shouldBe` x) + +-- | Same as `shouldBe`, except it checks that the value is `Just` +shouldBeJust :: (HasCallStack, Show a, Eq a) => Maybe a -> a -> Expectation +shouldBeJust e x = expectJust e >>= (`shouldBe` x) + +-- | Return value from the `Just` an fail otherwise +-- +-- Difference from @`shouldSatisfy` action `isJust`@ in that `expectJust` will force the +-- content of the `Just` to WHNF and it will also return it. +expectJust :: HasCallStack => Maybe a -> IO a +expectJust (Just x) = pure $! x +expectJust Nothing = assertFailure "Expected Just, got Nothing" + +-- | Same as `expectJust`, but will force the value to NF +expectJustDeep :: (HasCallStack, NFData a) => Maybe a -> IO a +expectJustDeep = expectJust >=> evaluateDeep + +-- | Same as `expectJustDeep`, but will discard the forced contents of `Just` +expectJustDeep_ :: (HasCallStack, NFData a) => Maybe a -> IO () +expectJustDeep_ = void . expectJustDeep + +-- | Same as @`shouldSatisfy` action `Data.Maybe.isNothing`@ +expectNothing :: (HasCallStack, Show a) => Maybe a -> IO () +expectNothing (Just x) = assertFailure $ "Expected Nothing, got Just: " ++ show x +expectNothing Nothing = pure () + +-- | Convert the top call from the `CallStack` to hspec's `Location` +callStackToLocation :: CallStack -> Maybe Location +callStackToLocation cs = + case getCallStack cs of + [] -> Nothing + (_, loc) : _ -> Just $ srcLocToLocation loc + +-- | Convert `SrcLoc` to hspec's `Location` +srcLocToLocation :: SrcLoc -> Location +srcLocToLocation loc = + Location + { locationFile = srcLocFile loc + , locationLine = srcLocStartLine loc + , locationColumn = srcLocStartCol loc + } diff --git a/libs/ImpSpec/src/Test/ImpSpec/Expectations/Lifted.hs b/libs/ImpSpec/src/Test/ImpSpec/Expectations/Lifted.hs new file mode 100644 index 00000000000..cd77b05e495 --- /dev/null +++ b/libs/ImpSpec/src/Test/ImpSpec/Expectations/Lifted.hs @@ -0,0 +1,148 @@ +module Test.ImpSpec.Expectations.Lifted ( + -- * Lifted Expectations + io, + + -- ** Common + assertBool, + assertFailure, + expectationFailure, + shouldBe, + shouldSatisfy, + shouldStartWith, + shouldEndWith, + shouldContain, + shouldMatchList, + shouldReturn, + shouldNotBe, + shouldNotSatisfy, + shouldNotContain, + shouldNotReturn, + shouldThrow, + IO.Selector, + + -- ** Custom + assertColorFailure, + + -- *** Either + shouldBeRight, + shouldBeLeft, + expectRight, + expectRightDeep, + expectRightDeep_, + expectLeft, + expectLeftDeep, + expectLeftDeep_, + + -- *** Maybe + shouldBeJust, + expectJust, + expectJustDeep, + expectJustDeep_, + expectNothing, +) where + +import Control.DeepSeq (NFData) +import GHC.Stack (HasCallStack) +import Test.Hspec.Expectations.Lifted ( + expectationFailure, + shouldBe, + shouldContain, + shouldEndWith, + shouldMatchList, + shouldNotBe, + shouldNotContain, + shouldNotReturn, + shouldNotSatisfy, + shouldReturn, + shouldSatisfy, + shouldStartWith, + ) +import qualified Test.ImpSpec.Expectations as IO +import UnliftIO (Exception, MonadIO (liftIO), MonadUnliftIO, withRunInIO) + +infix 1 `shouldThrow` + , `shouldBeRight` + , `shouldBeLeft` + +-- | Enforce the type of expectation +-- +-- Useful with polymorphic expectations that are defined below. +-- +-- ===__Example__ +-- +-- Because `shouldBeExpr` is polymorphic in `m`, compiler will choke with a unification +-- error. This is due to the fact that hspec's `it` expects a polymorphic `Example`. +-- +-- > it "MyTest" $ do +-- > "foo" `shouldBeExpr` "bar" +-- +-- However, this is easily solved by `io`: +-- +-- > it "MyTest" $ io $ do +-- > "foo" `shouldBeExpr` "bar" +io :: IO a -> IO a +io = id + +-- | Just like `expectationFailure`, but does not force the return type to unit. Lifted +-- version of `H.assertFailure` +assertFailure :: (HasCallStack, MonadIO m) => String -> m a +assertFailure = liftIO . IO.assertFailure + +assertColorFailure :: (HasCallStack, MonadIO m) => String -> m a +assertColorFailure = liftIO . IO.assertColorFailure + +-- | Lifted version of `H.assertBool` +assertBool :: (HasCallStack, MonadIO m) => String -> Bool -> m () +assertBool msg = liftIO . IO.assertBool msg + +-- | Lifted version of `shouldThrow`. +shouldThrow :: (HasCallStack, Exception e, MonadUnliftIO m) => m a -> IO.Selector e -> m () +shouldThrow f s = withRunInIO $ \run -> IO.shouldThrow (run f) s + +-- | Return value on the `Right` and fail otherwise. Lifted version of `H.expectRight`. +expectRight :: (HasCallStack, Show a, MonadIO m) => Either a b -> m b +expectRight = liftIO . IO.expectRight + +-- | Same as `expectRight`, but also evaluate the returned value to NF +expectRightDeep :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m b +expectRightDeep = liftIO . IO.expectRightDeep + +-- | Same as `expectRightDeep`, but discards the result +expectRightDeep_ :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m () +expectRightDeep_ = liftIO . IO.expectRightDeep_ + +-- | Same as `shouldBe`, except it checks that the value is `Right` +shouldBeRight :: (HasCallStack, Show a, Show b, Eq b, MonadIO m) => Either a b -> b -> m () +shouldBeRight e = liftIO . IO.shouldBeRight e + +-- | Return value on the `Left` and fail otherwise +expectLeft :: (HasCallStack, Show b, MonadIO m) => Either a b -> m a +expectLeft = liftIO . IO.expectLeft + +-- | Same as `expectLeftDeep`, but discards the result +expectLeftDeep_ :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m () +expectLeftDeep_ = liftIO . IO.expectLeftDeep_ + +-- | Same as `expectLeft`, but also evaluate the returned value to NF +expectLeftDeep :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m a +expectLeftDeep = liftIO . IO.expectLeftDeep + +-- | Same as `shouldBe`, except it checks that the value is `Left` +shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b, MonadIO m) => Either a b -> a -> m () +shouldBeLeft e x = liftIO $ e `IO.shouldBeLeft` x + +-- | Same as `shouldBe`, except it checks that the value is `Just` +shouldBeJust :: (HasCallStack, Show a, Eq a, MonadIO m) => Maybe a -> a -> m () +shouldBeJust e x = liftIO $ e `IO.shouldBeJust` x + +expectJust :: (HasCallStack, MonadIO m) => Maybe a -> m a +expectJust = liftIO . IO.expectJust + +expectJustDeep :: (HasCallStack, NFData a, MonadIO m) => Maybe a -> m a +expectJustDeep = liftIO . IO.expectJustDeep + +expectJustDeep_ :: (HasCallStack, NFData a, MonadIO m) => Maybe a -> m () +expectJustDeep_ = liftIO . IO.expectJustDeep_ + +expectNothing :: (HasCallStack, Show a, MonadIO m) => Maybe a -> m () +expectNothing = liftIO . IO.expectNothing diff --git a/libs/ImpSpec/src/Test/ImpSpec/Internal.hs b/libs/ImpSpec/src/Test/ImpSpec/Internal.hs new file mode 100644 index 00000000000..cb9e58c7970 --- /dev/null +++ b/libs/ImpSpec/src/Test/ImpSpec/Internal.hs @@ -0,0 +1,388 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.ImpSpec.Internal where + +import Control.DeepSeq (NFData) +import Control.Monad (void) +import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) +import Control.Monad.State.Strict (MonadState (..)) +import Data.Kind (Type) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack) +import Prettyprinter ( + Doc, + Pretty (..), + annotate, + defaultLayoutOptions, + hcat, + indent, + layoutPretty, + line, + vsep, + ) +import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, renderLazy) +import System.Random (randomR, split) +import System.Random.Stateful (IOGenM, applyIOGen, newIOGenM) +import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..)) +import Test.Hspec (Spec, SpecWith, beforeAll, beforeAllWith) +import Test.Hspec.Core.Spec ( + Example (..), + Result (..), + paramsQuickCheckArgs, + ) +import qualified Test.Hspec.Core.Spec as H +import Test.ImpSpec.Expectations +import Test.ImpSpec.Random +import Test.QuickCheck (Arbitrary, Args (chatty, replay), Testable (..), counterexample, ioProperty) +import Test.QuickCheck.Gen (Gen (..)) +import Test.QuickCheck.GenT (MonadGen (..)) +import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen) +import UnliftIO (MonadIO (liftIO), MonadUnliftIO (..)) +import UnliftIO.Exception ( + Exception (..), + SomeException (..), + catchAny, + catchAnyDeep, + throwIO, + ) +import UnliftIO.IORef + +data ImpState t = ImpState + { impStateSpecState :: !(ImpSpecState t) + , impStateLog :: !(Doc AnsiStyle) + } + +data ImpEnv t = ImpEnv + { impEnvSpecEnv :: !(ImpSpecEnv t) + , impEnvStateRef :: !(IORef (ImpState t)) + , impEnvQCGenRef :: !(IOGenM QCGen) + , impEnvQCSize :: !Int + } + +class ImpSpec t where + type ImpSpecEnv t = (r :: Type) | r -> t + type ImpSpecEnv t = Proxy t + type ImpSpecState t = (r :: Type) | r -> t + type ImpSpecState t = Proxy t + + impInitIO :: QCGen -> IO (ImpInit t) + default impInitIO :: (ImpSpecEnv t ~ Proxy t, ImpSpecState t ~ Proxy t) => QCGen -> IO (ImpInit t) + impInitIO _ = pure $ ImpInit Proxy Proxy + + -- | This will be the very first action that will run in all `ImpM` specs. + impPrepAction :: ImpM t () + impPrepAction = pure () + +data ImpInit t = ImpInit + { impInitEnv :: ImpSpecEnv t + , impInitState :: ImpSpecState t + } +deriving instance (Eq (ImpSpecEnv t), Eq (ImpSpecState t)) => Eq (ImpInit t) +deriving instance (Ord (ImpSpecEnv t), Ord (ImpSpecState t)) => Ord (ImpInit t) +deriving instance (Show (ImpSpecEnv t), Show (ImpSpecState t)) => Show (ImpInit t) + +-- | Stores extra information about the failure of the unit test +data ImpException = ImpException + { ieAnnotation :: [Doc AnsiStyle] + -- ^ Description of the IO action that caused the failure + , ieThrownException :: SomeException + -- ^ Exception that caused the test to fail + } + deriving (Show) + +instance Exception ImpException where + displayException = ansiDocToString . prettyImpException + +prettyImpException :: ImpException -> Doc AnsiStyle +prettyImpException (ImpException ann e) = + vsep $ + mconcat + [ ["Annotations:"] + , zipWith indent [0, 2 ..] ann + , ["Failed with Exception:", indent 4 $ pretty (displayException e)] + ] + +newtype ImpM t a = ImpM {unImpM :: ReaderT (ImpEnv t) IO a} + deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadUnliftIO + ) + +instance env ~ ImpSpecEnv t => MonadReader env (ImpM t) where + ask = impEnvSpecEnv <$> ImpM ask + local f = ImpM . local (\e -> e {impEnvSpecEnv = f (impEnvSpecEnv e)}) . unImpM + +instance MonadFail (ImpM t) where + fail = liftIO . assertFailure + +instance s ~ ImpSpecState t => MonadState s (ImpM t) where + state f = do + ImpEnv {impEnvStateRef} <- ImpM ask + curState <- readIORef impEnvStateRef + let !(result, !newSpecState) = f $ impStateSpecState curState + writeIORef impEnvStateRef (curState {impStateSpecState = newSpecState}) + pure result + get = fmap impStateSpecState . readIORef . impEnvStateRef =<< ImpM ask + +instance MonadGen (ImpM t) where + liftGen (MkGen f) = do + qcSize <- ImpM $ asks impEnvQCSize + qcGen <- applyQCGen split + pure $ f qcGen qcSize + variant n action = do + applyQCGen $ \qcGen -> ((), integerVariant (toInteger n) qcGen) + action + sized f = ImpM (asks impEnvQCSize) >>= f + resize n (ImpM f) = ImpM $ local (\env -> env {impEnvQCSize = n}) f + choose r = applyQCGen (randomR r) + +instance HasStatefulGen (IOGenM QCGen) (ImpM t) where + askStatefulGen = ImpM $ asks impEnvQCGenRef + +instance (ImpSpec t, Testable a) => Testable (ImpM t a) where + property m = property $ MkGen $ \qcGen qcSize -> + ioProperty $ do + let (qcGen1, qcGen2) = split qcGen + impInit <- impInitIO qcGen1 + evalImpM (Just qcGen2) (Just qcSize) impInit m + +instance (ImpSpec t, Testable p) => Example (ImpM t p) where + type Arg (ImpM t p) = ImpInit t + + evaluateExample impTest = evaluateExample (\() -> impTest) + +instance (Arbitrary a, Show a, ImpSpec t, Testable p) => Example (a -> ImpM t p) where + type Arg (a -> ImpM t p) = ImpInit t + + evaluateExample impTest params hook progressCallback = do + let runImpExample impInit = property $ \x -> do + let args = paramsQuickCheckArgs params + mQC = replay (paramsQuickCheckArgs params) + + (r, testable, logs) <- evalImpM (fst <$> mQC) (snd <$> mQC) impInit $ do + t <- impTest x + qcSize <- ImpM $ asks impEnvQCSize + qcGen <- applyQCGen split + logs <- getLogs + pure (Just (qcGen, qcSize), t, logs) + let params' = params {paramsQuickCheckArgs = args {replay = r, chatty = False}} + res <- + evaluateExample + (counterexample (ansiDocToString logs) testable) + params' + (\f -> hook (\_st -> f ())) + progressCallback + void $ throwIO $ resultStatus res + evaluateExample runImpExample params hook progressCallback + +applyQCGen :: (QCGen -> (b, QCGen)) -> ImpM t b +applyQCGen f = do + qcGenRef <- ImpM $ asks impEnvQCGenRef + applyIOGen f qcGenRef + +getLogs :: ImpM t (Doc AnsiStyle) +getLogs = do + ref <- ImpM $ asks impEnvStateRef + impStateLog <$> readIORef ref + +modifyLogs :: (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t () +modifyLogs f = do + ref <- ImpM $ asks impEnvStateRef + modifyIORef ref $ \s -> s {impStateLog = f (impStateLog s)} + +-- | Override the QuickCheck generator using a fixed seed. +impSetSeed :: Int -> ImpM t () +impSetSeed seed = applyQCGen $ \_ -> ((), mkQCGen seed) + +evalImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO b) +evalImpGenM impInit = fmap (fmap fst) . runImpGenM impInit + +evalImpM :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b +evalImpM mQCGen mQCSize impInit = fmap fst . runImpM mQCGen mQCSize impInit + +execImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (ImpState t)) +execImpGenM impInit = fmap (fmap snd) . runImpGenM impInit + +execImpM :: + ImpSpec t => + Maybe QCGen -> + Maybe Int -> + ImpInit t -> + ImpM t b -> + IO (ImpState t) +execImpM mQCGen mQCSize impInit = fmap snd . runImpM mQCGen mQCSize impInit + +runImpGenM_ :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO ()) +runImpGenM_ impInit = fmap void . runImpGenM impInit + +runImpM_ :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO () +runImpM_ mQCGen mQCSize impInit = void . runImpM mQCGen mQCSize impInit + +runImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t)) +runImpGenM impInit m = + MkGen $ \qcGen qcSize -> runImpM (Just qcGen) (Just qcSize) impInit m + +runImpM :: + ImpSpec t => + Maybe QCGen -> + Maybe Int -> + ImpInit t -> + ImpM t b -> + IO (b, ImpState t) +runImpM mQCGen mQCSize ImpInit {impInitEnv, impInitState} action = do + let qcSize = fromMaybe 30 mQCSize + qcGen = fromMaybe (mkQCGen 2024) mQCGen + ioRef <- + newIORef $ + ImpState + { impStateSpecState = impInitState + , impStateLog = mempty + } + qcGenRef <- newIOGenM qcGen + let + env = + ImpEnv + { impEnvSpecEnv = impInitEnv + , impEnvStateRef = ioRef + , impEnvQCGenRef = qcGenRef + , impEnvQCSize = qcSize + } + res <- + runReaderT (unImpM (impPrepAction >> action)) env `catchAny` \exc -> do + logs <- impStateLog <$> readIORef ioRef + let x my = case my of + Nothing -> x + Just y -> x ++ [pretty y] + uncaughtException header excThrown = + H.ColorizedReason $ + ansiDocToString $ + vsep $ + header ++ [pretty $ "Uncaught Exception: " <> displayException excThrown] + fromHUnitFailure header (HUnitFailure mSrcLoc failReason) = + case failReason of + Reason msg -> + H.Failure (srcLocToLocation <$> mSrcLoc) $ + H.ColorizedReason $ + ansiDocToString $ + vsep $ + header ++ [annotate (color Red) (pretty msg)] + ExpectedButGot mMsg expected got -> + H.Failure (srcLocToLocation <$> mSrcLoc) $ + H.ExpectedButGot (Just (ansiDocToString $ vsep (header mMsg))) expected got + adjustFailureReason header = \case + H.Failure mLoc failureReason -> + H.Failure mLoc $ + case failureReason of + H.NoReason -> + H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) "NoReason"] + H.Reason msg -> + H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) (pretty msg)] + H.ColorizedReason msg -> + H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [pretty msg] + H.ExpectedButGot mPreface expected actual -> + H.ExpectedButGot (Just (ansiDocToString $ vsep (header mPreface))) expected actual + H.Error mInfo excThrown -> uncaughtException (header mInfo) excThrown + result -> result + newExc + | Just hUnitExc <- fromException exc = fromHUnitFailure [logs] hUnitExc + | Just hspecFailure <- fromException exc = adjustFailureReason [logs] hspecFailure + | Just (ImpException ann excThrown) <- fromException exc = + let annLen = length ann + header = + logs + : [ let prefix + | annLen <= 1 = "╺╸" + | n <= 0 = "┏╸" + | n + 1 == annLen = indent (n - 1) "┗━╸" + | otherwise = indent (n - 1) "┗┳╸" + in annotate (color Red) prefix <> annotate (color Yellow) a + | (n, a) <- zip [0 ..] ann + ] + ++ [""] + in case fromException excThrown of + Just hUnitExc -> fromHUnitFailure header hUnitExc + Nothing -> + case fromException excThrown of + Just hspecFailure -> adjustFailureReason header hspecFailure + Nothing -> H.Failure Nothing $ uncaughtException header excThrown + | otherwise = H.Failure Nothing $ uncaughtException [logs] exc + throwIO newExc + endState <- readIORef ioRef + pure (res, endState) + +ansiDocToString :: Doc AnsiStyle -> String +ansiDocToString = TL.unpack . renderLazy . layoutPretty defaultLayoutOptions + +withImpInit :: ImpSpec t => SpecWith (ImpInit t) -> Spec +withImpInit = beforeAll (impInitIO (mkQCGen 2024)) + +modifyImpInit :: (ImpInit t -> ImpInit t) -> SpecWith (ImpInit t) -> SpecWith (ImpInit t) +modifyImpInit f = beforeAllWith (pure . f) + +-- | Annotation for when failure happens. All the logging done within annotation will be +-- discarded if there no failures within the annotation. +impAnn :: NFData a => String -> ImpM t a -> ImpM t a +impAnn msg = impAnnDoc (pretty msg) + +impAnnDoc :: NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a +impAnnDoc msg m = do + logs <- getLogs + res <- catchAnyDeep m $ \exc -> + throwIO $ + case fromException exc of + Just (ImpException ann origExc) -> ImpException (msg : ann) origExc + Nothing -> ImpException [msg] exc + modifyLogs (const logs) + pure res + +-- | Adds a source location and Doc to the log, which are only shown if the test fails +logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpM t () +logWithCallStack callStack entry = + modifyLogs (<> stack <> line <> indent 2 entry <> line) + where + prettySrcLoc' SrcLoc {srcLocModule, srcLocStartLine} = + hcat + [ annotate (color c) d + | (c, d) <- + [ (Yellow, "[") + , (Blue, pretty srcLocModule) + , (Yellow, ":") + , (Magenta, pretty srcLocStartLine) + , (Yellow, "]") + ] + ] + prefix n = if n <= 0 then "" else indent (n - 1) "└" + stack = + vsep + [prefix n <> prettySrcLoc' loc | (n, (_, loc)) <- zip [0, 2 ..] . reverse $ getCallStack callStack] + +-- | Adds a Doc to the log, which is only shown if the test fails +logDoc :: HasCallStack => Doc AnsiStyle -> ImpM t () +logDoc = logWithCallStack ?callStack + +-- | Adds a Text to the log, which is only shown if the test fails +logText :: HasCallStack => Text -> ImpM t () +logText = logWithCallStack ?callStack . pretty + +-- | Adds a String to the log, which is only shown if the test fails +logString :: HasCallStack => String -> ImpM t () +logString = logWithCallStack ?callStack . pretty diff --git a/libs/ImpSpec/src/Test/ImpSpec/Main.hs b/libs/ImpSpec/src/Test/ImpSpec/Main.hs new file mode 100644 index 00000000000..e9962441662 --- /dev/null +++ b/libs/ImpSpec/src/Test/ImpSpec/Main.hs @@ -0,0 +1,31 @@ +module Test.ImpSpec.Main ( + impSpecMain, + impSpecConfig, + impSpecMainWithConfig, +) where + +import System.IO ( + BufferMode (LineBuffering), + hSetBuffering, + hSetEncoding, + stdout, + utf8, + ) +import Test.Hspec +import Test.Hspec.Core.Runner (ColorMode (ColorAlways), Config (..), defaultConfig, hspecWith) + +impSpecConfig :: Config +impSpecConfig = + defaultConfig + { configTimes = True + , configColorMode = ColorAlways + } + +impSpecMainWithConfig :: Config -> Spec -> IO () +impSpecMainWithConfig conf spec = do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 + hspecWith conf spec + +impSpecMain :: Spec -> IO () +impSpecMain = impSpecMainWithConfig impSpecConfig diff --git a/libs/ImpSpec/src/Test/ImpSpec/Random.hs b/libs/ImpSpec/src/Test/ImpSpec/Random.hs new file mode 100644 index 00000000000..aa5805bcd3d --- /dev/null +++ b/libs/ImpSpec/src/Test/ImpSpec/Random.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.ImpSpec.Random where + +import Control.Monad (replicateM) +import Control.Monad.Reader (MonadReader (ask), ReaderT (..)) +import Data.ByteString (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified System.Random.Stateful as R +import qualified Test.QuickCheck as QC (Arbitrary (arbitrary)) +import Test.QuickCheck.GenT (MonadGen (liftGen)) + +class R.StatefulGen g m => HasStatefulGen g m | m -> g where + askStatefulGen :: m g + default askStatefulGen :: MonadReader g m => m g + askStatefulGen = ask + +class HasGenEnv env g | env -> g where + getGenEnv :: env -> g + +instance HasGenEnv g g where + getGenEnv = id + +instance + (HasGenEnv env g, R.StatefulGen g (ReaderT env m), Monad m) => + HasStatefulGen g (ReaderT env m) + where + askStatefulGen = ReaderT (pure . getGenEnv) + +uniformM :: + ( HasStatefulGen g m + , R.Uniform a + ) => + m a +uniformM = askStatefulGen >>= R.uniformM +{-# INLINE uniformM #-} + +uniformRM :: + ( HasStatefulGen g m + , R.UniformRange a + ) => + (a, a) -> + m a +uniformRM r = askStatefulGen >>= R.uniformRM r +{-# INLINE uniformRM #-} + +uniformListM :: + ( HasStatefulGen g m + , R.Uniform a + ) => + Int -> + m [a] +uniformListM n = askStatefulGen >>= R.uniformListM n +{-# INLINE uniformListM #-} + +uniformListRM :: + (HasStatefulGen g m, R.UniformRange a) => + (a, a) -> + Int -> + m [a] +uniformListRM r n = askStatefulGen >>= replicateM n . R.uniformRM r +{-# INLINE uniformListRM #-} + +uniformByteStringM :: HasStatefulGen a m => Int -> m ByteString +uniformByteStringM n = askStatefulGen >>= R.uniformByteStringM n +{-# INLINE uniformByteStringM #-} + +uniformShortByteStringM :: HasStatefulGen a m => Int -> m ShortByteString +uniformShortByteStringM n = askStatefulGen >>= R.uniformShortByteString n +{-# INLINE uniformShortByteStringM #-} + +-- | Lifted version of `QC.arbitrary`. +arbitrary :: (QC.Arbitrary a, MonadGen m) => m a +arbitrary = liftGen QC.arbitrary diff --git a/libs/ImpSpec/test/Main.hs b/libs/ImpSpec/test/Main.hs new file mode 100644 index 00000000000..3cc2dae209e --- /dev/null +++ b/libs/ImpSpec/test/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.ImpSpec +import Test.Suite.ImpSpec (spec) + +main :: IO () +main = impSpecMain $ describe "ImpSpec" spec diff --git a/libs/ImpSpec/test/Test/Suite/ImpSpec.hs b/libs/ImpSpec/test/Test/Suite/ImpSpec.hs new file mode 100644 index 00000000000..040cbbfce2f --- /dev/null +++ b/libs/ImpSpec/test/Test/Suite/ImpSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Suite.ImpSpec (spec) where + +import Test.ImpSpec + +data I + +instance ImpSpec I + +spec :: Spec +spec = + describe "ImpSpec" $ do + describe "Expectations" $ do + it "shouldBeLeft" $ io $ do + Left @() @Int () `shouldBeLeft` () + withImpInit @I $ + describe "ImpM" $ do + it "impSetSeed" $ do + impSetSeed 1234 + arbitrary `shouldReturn` 'F' diff --git a/libs/cardano-ledger-api/cardano-ledger-api.cabal b/libs/cardano-ledger-api/cardano-ledger-api.cabal index 950a4bc65a2..e2c8f7d3f68 100644 --- a/libs/cardano-ledger-api/cardano-ledger-api.cabal +++ b/libs/cardano-ledger-api/cardano-ledger-api.cabal @@ -59,7 +59,7 @@ library cardano-ledger-babbage >=1.10.1 && <=1.11, cardano-ledger-binary >=1.4, cardano-ledger-conway >=1.13 && <1.19, - cardano-ledger-core >=1.15 && <1.17, + cardano-ledger-core >=1.16 && <1.17, cardano-ledger-mary ^>=1.7, cardano-ledger-shelley ^>=1.15, cardano-strict-containers, diff --git a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs index cdd079661e8..80fcac1f655 100644 --- a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs +++ b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs @@ -42,7 +42,7 @@ import Test.Cardano.Ledger.Imp.Common spec :: forall era. ConwayEraImp era => - SpecWith (ImpTestState era) + SpecWith (ImpInit (LedgerSpec era)) spec = do describe "DRep" $ do describe "Expiries are reported correctly" $ do diff --git a/libs/cardano-ledger-api/test/Tests.hs b/libs/cardano-ledger-api/test/Tests.hs index 7d199c95052..acce1fe5520 100644 --- a/libs/cardano-ledger-api/test/Tests.hs +++ b/libs/cardano-ledger-api/test/Tests.hs @@ -3,15 +3,15 @@ module Main where -import Cardano.Ledger.BaseTypes (natVersion) import Cardano.Ledger.Conway (Conway) +import Cardano.Ledger.Core import qualified Test.Cardano.Ledger.Api.State.Imp.QuerySpec as ImpQuery (spec) import qualified Test.Cardano.Ledger.Api.State.QuerySpec as StateQuery (spec) import qualified Test.Cardano.Ledger.Api.Tx as Tx (spec) import qualified Test.Cardano.Ledger.Api.Tx.Body as TxBody (spec) import qualified Test.Cardano.Ledger.Api.Tx.Out as TxOut (spec) -import Test.Cardano.Ledger.Common -import Test.Cardano.Ledger.Conway.ImpTest (withImpStateWithProtVer) +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Shelley.ImpTest (LedgerSpec, modifyImpInitProtVer) -- ==================================================================================== @@ -25,9 +25,10 @@ apiSpec = describe "State" $ do StateQuery.spec describe "Imp" $ - forM_ [natVersion @9, natVersion @10] $ \v -> - withImpStateWithProtVer @Conway v $ do - ImpQuery.spec @Conway + withImpInit @(LedgerSpec Conway) $ + forM_ (eraProtVersions @Conway) $ \v -> + modifyImpInitProtVer v $ do + ImpQuery.spec @Conway main :: IO () main = ledgerTestMain apiSpec diff --git a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal index 55c389ccf46..ccadd033112 100644 --- a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal +++ b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal @@ -114,6 +114,7 @@ library testlib cuddle >=0.3.2, formatting, tree-diff, + ImpSpec, iproute, half, hedgehog, diff --git a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/TreeDiff.hs b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/TreeDiff.hs index 35e55090f32..8bb5b2a23f3 100644 --- a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/TreeDiff.hs +++ b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/TreeDiff.hs @@ -44,7 +44,6 @@ import Cardano.Crypto.Hash.Class () import Cardano.Ledger.Binary import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Term as CBOR -import Control.Exception (throwIO) import Data.Bifunctor (bimap) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 @@ -54,42 +53,17 @@ import Data.Foldable (toList) import Data.IP (IPv4, IPv6) import Data.Maybe.Strict (StrictMaybe) import Data.Sequence.Strict (StrictSeq) -import qualified Data.Text.Lazy as TL import Data.TreeDiff -import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack) +import GHC.Stack (HasCallStack) import Prettyprinter (Doc) import qualified Prettyprinter as Pretty import Prettyprinter.Render.Terminal (AnsiStyle) -import qualified Prettyprinter.Render.Terminal as Pretty import Test.Cardano.Slotting.TreeDiff () import Test.Hspec (Expectation) -import Test.Hspec.Core.Spec ( - FailureReason (ColorizedReason), - Location (..), - ResultStatus (Failure), - ) +import Test.ImpSpec (ansiDocToString) +import Test.ImpSpec.Expectations (assertColorFailure, callStackToLocation, srcLocToLocation) import Test.Tasty.HUnit (Assertion, assertFailure) -callStackToLocation :: CallStack -> Maybe Location -callStackToLocation cs = - case getCallStack cs of - [] -> Nothing - (_, loc) : _ -> Just $ srcLocToLocation loc - -srcLocToLocation :: SrcLoc -> Location -srcLocToLocation loc = - Location - { locationFile = srcLocFile loc - , locationLine = srcLocStartLine loc - , locationColumn = srcLocStartCol loc - } - --- | Similar to `assertFailure`, except hspec will not interfer with any escape sequences --- that indicate color output. -assertColorFailure :: HasCallStack => String -> IO a -assertColorFailure msg = - throwIO $ Failure (callStackToLocation ?callStack) (ColorizedReason msg) - -- ===================================================== -- Cardano functions that deal with TreeDiff and ToExpr @@ -152,9 +126,6 @@ diffExprCompact x y = ansiWlEditExprCompact (ediff x y) diffExprCompactString :: ToExpr a => a -> a -> String diffExprCompactString x y = ansiDocToString $ diffExprCompact x y -ansiDocToString :: Doc AnsiStyle -> String -ansiDocToString = TL.unpack . Pretty.renderLazy . Pretty.layoutPretty Pretty.defaultLayoutOptions - -- | Wraps regular ByteString, but shows and diffs it as hex newtype HexBytes = HexBytes {unHexBytes :: BS.ByteString} deriving (Eq) diff --git a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp/Ratify.hs b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp/Ratify.hs index 2531520d62b..d38e60777ca 100644 --- a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp/Ratify.hs +++ b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp/Ratify.hs @@ -5,10 +5,10 @@ module Test.Cardano.Ledger.Conformance.Imp.Ratify (spec) where -import Cardano.Ledger.BaseTypes (EpochInterval (..), StrictMaybe (..), addEpochInterval, natVersion) +import Cardano.Ledger.BaseTypes (EpochInterval (..), StrictMaybe (..), addEpochInterval) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway (Conway) -import Cardano.Ledger.Conway.Core (CoinPerByte (..), ppCoinsPerUTxOByteL, ppCommitteeMinSizeL) +import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance ( Committee (..), GovAction (..), @@ -20,9 +20,6 @@ import Cardano.Ledger.Conway.Governance ( ) import Cardano.Ledger.Conway.PParams ( dvtMotionNoConfidenceL, - ppCommitteeMaxTermLengthL, - ppDRepVotingThresholdsL, - ppPoolVotingThresholdsL, pvtMotionNoConfidenceL, ) import Cardano.Ledger.Credential (Credential (..)) @@ -48,7 +45,7 @@ import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) import Test.Cardano.Ledger.Imp.Common spec :: Spec -spec = describe "RATIFY" . withImpStateWithProtVer @Conway (natVersion @10) $ do +spec = withImpInit @(LedgerSpec Conway) $ describe "RATIFY" $ modifyImpInitProtVer (eraProtVerHigh @Conway) $ do it "NoConfidence accepted conforms" $ do modifyPParams $ \pp -> pp diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 87ff365abc1..03edd4eee05 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.16.0.0 +* Add `eraProtVersions` * Remove deprecated `_unTxId` and `adaOnly` * Remove deprecated module `Cardano.Ledger.Serialization` * Remove deprecated `fromSLanguage` @@ -31,6 +32,9 @@ ### `testlib` +* Switch to using `ImpSpec` package +* Remove `HasSubState`, `subStateM`, `setSubStateM`, `StateGen` and `StateGenM` as no longer useful. +* Re-export `withImpInit` and `modifyImpInit` * Remove deprecated `mkVKeyRwdAcnt` * Remove deprecated `deserialiseRewardAcntOld` * Generalize the return type of `assertColorFailure` to `MonadIO` diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 09ad9e3de80..09ec9433a91 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -187,7 +187,7 @@ library testlib hspec, hedgehog-quickcheck, here, - HUnit, + ImpSpec, mtl, nothunks, prettyprinter, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs index b9a388d0f08..38998f49954 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs @@ -41,6 +41,7 @@ module Cardano.Ledger.Core.Era ( notSupportedInThisEraL, eraProtVerLow, eraProtVerHigh, + eraProtVersions, toEraCBOR, fromEraCBOR, fromEraShareCBOR, @@ -237,6 +238,10 @@ eraProtVerLow = natVersion @(ProtVerLow era) eraProtVerHigh :: forall era. Era era => Version eraProtVerHigh = natVersion @(ProtVerHigh era) +-- | List with all major versions that are used in the particular era. +eraProtVersions :: forall era. Era era => [Version] +eraProtVersions = [eraProtVerLow @era .. eraProtVerHigh @era] + -- | Enforce era to be at least the specified era at the type level. In other words -- compiler will produce type error when applied to eras prior to the specified era. -- This function should be used in order to avoid redundant constraints warning. diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Common.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Common.hs index 2b65553bfa7..b39f5bce5cb 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Common.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Common.hs @@ -46,19 +46,10 @@ where import Control.DeepSeq (NFData) import Control.Monad as X (forM_, replicateM, replicateM_, unless, void, when, (>=>)) import qualified Debug.Trace as Debug -import System.IO ( - BufferMode (LineBuffering), - hSetBuffering, - hSetEncoding, - stdout, - utf8, - ) import Test.Cardano.Ledger.Binary.TreeDiff ( ToExpr (..), - ansiDocToString, ansiExpr, ansiExprString, - assertColorFailure, diffExpr, diffExprCompact, diffExprCompactString, @@ -66,31 +57,23 @@ import Test.Cardano.Ledger.Binary.TreeDiff ( expectExprEqualWithMessage, showExpr, ) -import Test.HUnit.Base (assertBool, assertFailure) import Test.Hspec as X import Test.Hspec.QuickCheck as X import Test.Hspec.Runner +import Test.ImpSpec (ansiDocToString, impSpecConfig, impSpecMainWithConfig) +import Test.ImpSpec.Expectations import Test.QuickCheck as X import UnliftIO.Exception (evaluateDeep) infix 1 `shouldBeExpr` - , `shouldBeRight` , `shouldBeRightExpr` - , `shouldBeLeft` , `shouldBeLeftExpr` ledgerHspecConfig :: Config -ledgerHspecConfig = - defaultConfig - { configTimes = True - , configColorMode = ColorAlways - } +ledgerHspecConfig = impSpecConfig ledgerTestMainWith :: Config -> Spec -> IO () -ledgerTestMainWith conf spec = do - hSetBuffering stdout LineBuffering - hSetEncoding stdout utf8 - hspecWith conf spec +ledgerTestMainWith = impSpecMainWithConfig ledgerTestMain :: Spec -> IO () ledgerTestMain = ledgerTestMainWith ledgerHspecConfig @@ -98,19 +81,6 @@ ledgerTestMain = ledgerTestMainWith ledgerHspecConfig shouldBeExpr :: (HasCallStack, ToExpr a, Eq a) => a -> a -> IO () shouldBeExpr = expectExprEqualWithMessage "" --- | Return value on the `Right` and fail otherwise -expectRight :: (HasCallStack, Show a) => Either a b -> IO b -expectRight (Right r) = pure $! r -expectRight (Left l) = assertFailure $ "Expected Right, got Left:\n" <> show l - --- | Same as `expectRight`, but also evaluate the returned value to NF -expectRightDeep :: (HasCallStack, Show a, NFData b) => Either a b -> IO b -expectRightDeep = expectRight >=> evaluateDeep - --- | Same as `expectRightDeep`, but discards the result -expectRightDeep_ :: (HasCallStack, Show a, NFData b) => Either a b -> IO () -expectRightDeep_ = void . expectRightDeep - -- | Same as `expectRight`, but use `ToExpr` instead of `Show` expectRightExpr :: (HasCallStack, ToExpr a) => Either a b -> IO b expectRightExpr (Right r) = pure $! r @@ -120,27 +90,10 @@ expectRightExpr (Left l) = assertFailure $ "Expected Right, got Left:\n" <> show expectRightDeepExpr :: (HasCallStack, ToExpr a, NFData b) => Either a b -> IO b expectRightDeepExpr = expectRightExpr >=> evaluateDeep --- | Same as `shouldBe`, except it checks that the value is `Right` -shouldBeRight :: (HasCallStack, Show a, Show b, Eq b) => Either a b -> b -> Expectation -shouldBeRight e x = expectRight e >>= (`shouldBe` x) - -- | Same as `shouldBeExpr`, except it checks that the value is `Right` shouldBeRightExpr :: (HasCallStack, ToExpr a, Eq b, ToExpr b) => Either a b -> b -> Expectation shouldBeRightExpr e x = expectRightExpr e >>= (`shouldBeExpr` x) --- | Return value on the `Left` an fail otherwise -expectLeft :: (HasCallStack, Show b) => Either a b -> IO a -expectLeft (Left l) = pure $! l -expectLeft (Right r) = assertFailure $ "Expected Left, got Right:\n" <> show r - --- | Same as `expectLeft`, but also evaluate the returned value to NF -expectLeftDeep :: (HasCallStack, NFData a, Show b) => Either a b -> IO a -expectLeftDeep = expectLeft >=> evaluateDeep - --- | Same as `expectLeftDeep`, but discards the result -expectLeftDeep_ :: (HasCallStack, NFData a, Show b) => Either a b -> IO () -expectLeftDeep_ = void . expectLeftDeep - -- | Same as `expectLeft`, but use `ToExpr` instead of `Show` expectLeftExpr :: (HasCallStack, ToExpr b) => Either a b -> IO a expectLeftExpr (Left l) = pure $! l @@ -150,14 +103,10 @@ expectLeftExpr (Right r) = assertFailure $ "Expected Left, got Right:\n" <> show expectLeftDeepExpr :: (HasCallStack, ToExpr b, NFData a) => Either a b -> IO a expectLeftDeepExpr = expectLeftExpr >=> evaluateDeep --- | Same as `shouldBe`, except it checks that the value is `Left` -shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b) => Either a b -> a -> Expectation -shouldBeLeft e x = expectLeft e >>= (`shouldBe` x) - -- | Same as `shouldBeExpr`, except it checks that the value is `Left` shouldBeLeftExpr :: (HasCallStack, ToExpr a, ToExpr b, Eq a) => Either a b -> a -> Expectation shouldBeLeftExpr e x = expectLeftExpr e >>= (`shouldBeExpr` x) -- | Same as `Test.QuickCheck.discard` but outputs a debug trace message -tracedDiscard :: [Char] -> a +tracedDiscard :: String -> a tracedDiscard message = (if False then Debug.trace $ "\nDiscarded trace: " ++ message else id) discard diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Imp/Common.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Imp/Common.hs index 9b05fa1f73d..89b7264a483 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Imp/Common.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Imp/Common.hs @@ -58,25 +58,23 @@ module Test.Cardano.Ledger.Imp.Common ( -- * Random interface HasStatefulGen (..), - HasGenEnv (..), - HasSubState (..), - subStateM, - setSubStateM, R.StatefulGen, - StateGen (..), - StateGenM (..), uniformM, uniformRM, uniformListM, uniformListRM, uniformByteStringM, uniformShortByteStringM, + + -- * Re-exports from ImpSpec + withImpInit, + modifyImpInit, ) where import Control.Monad.IO.Class -import Data.Functor.Const (Const (..)) -import Data.Functor.Identity (Identity (..)) +import Data.List (isInfixOf) +import qualified System.Random.Stateful as R import Test.Cardano.Ledger.Binary.TreeDiff (expectExprEqualWithMessage) import Test.Cardano.Ledger.Common as X hiding ( arbitrary, @@ -125,108 +123,38 @@ import Test.Cardano.Ledger.Common as X hiding ( variant, vectorOf, ) -import qualified Test.Cardano.Ledger.Common as H +import Test.ImpSpec (modifyImpInit, withImpInit) +import Test.ImpSpec.Expectations.Lifted +import Test.ImpSpec.Random ( + HasStatefulGen (..), + arbitrary, + uniformByteStringM, + uniformListM, + uniformListRM, + uniformM, + uniformRM, + uniformShortByteStringM, + ) import Test.QuickCheck.GenT as QuickCheckT import UnliftIO (MonadUnliftIO (..)) -import UnliftIO.Exception (Exception, evaluateDeep) - --- Imports needed for Random interface. Separated from the rest, since they will migrate --- to `random` at a later point: - -import Control.Monad.Reader -import Control.Monad.State -import Data.ByteString (ByteString) -import Data.ByteString.Short (ShortByteString) -import Data.Kind -import Data.List (isInfixOf) -import Foreign.Storable -import qualified System.Random.Stateful as R +import UnliftIO.Exception (evaluateDeep) instance MonadUnliftIO m => MonadUnliftIO (GenT m) where withRunInIO inner = GenT $ \qc sz -> withRunInIO $ \run -> inner $ \(GenT f) -> run (f qc sz) -infix 1 `shouldBe` - , `shouldBeExpr` - , `shouldSatisfy` - , `shouldStartWith` - , `shouldEndWith` - , `shouldContain` - , `shouldMatchList` - , `shouldReturn` - , `shouldThrow` - , `shouldNotBe` - , `shouldNotSatisfy` - , `shouldNotContain` - , `shouldNotReturn` - , `shouldBeRight` +infix 1 `shouldBeExpr` , `shouldBeRightExpr` - , `shouldBeLeft` , `shouldBeLeftExpr` --- | Enforce the type of expectation --- --- Useful with polymorphic expectations that are defined below. --- --- ===__Example__ --- --- Because `shouldBeExpr` is polymorphic in `m`, compiler will choke with a unification --- error. This is due to the fact that hspec's `it` expects a polymorphic `Example`. --- --- > it "MyTest" $ do --- > "foo" `shouldBeExpr` "bar" --- --- However, this is easily solved by `io`: --- --- > it "MyTest" $ io $ do --- > "foo" `shouldBeExpr` "bar" -io :: IO a -> IO a -io = id - --- | Just like `expectationFailure`, but does not force the return type to unit. Lifted --- version of `H.assertFailure` -assertFailure :: (HasCallStack, MonadIO m) => String -> m a -assertFailure = liftIO . H.assertFailure - -assertColorFailure :: (HasCallStack, MonadIO m) => String -> m a -assertColorFailure = liftIO . H.assertColorFailure - --- | Lifted version of `H.assertBool` -assertBool :: (HasCallStack, MonadIO m) => String -> Bool -> m () -assertBool msg = liftIO . H.assertBool msg - --- | Lifted version of `expectationFailure`. -expectationFailure :: (HasCallStack, MonadIO m) => String -> m () -expectationFailure = liftIO . H.expectationFailure - --- | Lifted version of `H.shouldBe`. -shouldBe :: (HasCallStack, Show a, Eq a, MonadIO m) => a -> a -> m () -shouldBe x y = liftIO $ H.shouldBe x y - shouldBeExpr :: (HasCallStack, ToExpr a, Eq a, MonadIO m) => a -> a -> m () shouldBeExpr expected actual = liftIO $ expectExprEqualWithMessage "" expected actual --- | Lifted version of `H.shouldSatisfy`. -shouldSatisfy :: (HasCallStack, Show a, MonadIO m) => a -> (a -> Bool) -> m () -shouldSatisfy x f = liftIO $ H.shouldSatisfy x f - shouldSatisfyExpr :: (HasCallStack, MonadIO m, ToExpr a) => a -> (a -> Bool) -> m () shouldSatisfyExpr x f | f x = pure () | otherwise = assertFailure $ "predicate failed on:\n" <> showExpr x --- | Lifted version of `H.shouldStartWith`. -shouldStartWith :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m () -shouldStartWith x y = liftIO $ H.shouldStartWith x y - --- | Lifted version of `H.shouldEndWith`. -shouldEndWith :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m () -shouldEndWith x y = liftIO $ H.shouldEndWith x y - --- | Lifted version of `H.shouldContain`. -shouldContain :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m () -shouldContain x y = liftIO $ H.shouldContain x y - shouldContainExpr :: (HasCallStack, ToExpr a, Eq a, MonadIO m) => [a] -> [a] -> m () shouldContainExpr x y | y `isInfixOf` x = pure () @@ -237,47 +165,6 @@ shouldContainExpr x y <> "\ndoes not contain\n" <> showExpr y --- | Lifted version of `H.shouldMatchList`. -shouldMatchList :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m () -shouldMatchList x y = liftIO $ H.shouldMatchList x y - --- | Lifted version of `H.shouldReturn`. -shouldReturn :: (HasCallStack, Show a, Eq a, MonadUnliftIO m) => m a -> a -> m () -shouldReturn f a = withRunInIO $ \run -> H.shouldReturn (run f) a - --- | Lifted version of `H.shouldNotBe`. -shouldNotBe :: (HasCallStack, Show a, Eq a, MonadIO m) => a -> a -> m () -shouldNotBe x y = liftIO $ H.shouldNotBe x y - --- | Lifted version of `H.shouldNotSatisfy`. -shouldNotSatisfy :: (HasCallStack, Show a, MonadIO m) => a -> (a -> Bool) -> m () -shouldNotSatisfy a f = liftIO $ H.shouldNotSatisfy a f - --- | Lifted version of `H.shouldNotContain`. -shouldNotContain :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m () -shouldNotContain x y = liftIO $ H.shouldNotContain x y - --- | Lifted version of `H.shouldNotReturn`. -shouldNotReturn :: (HasCallStack, Show a, Eq a, MonadUnliftIO m) => m a -> a -> m () -shouldNotReturn f a = withRunInIO $ \run -> H.shouldNotReturn (run f) a - --- | Lifted version of `shouldThrow`. -shouldThrow :: (HasCallStack, Exception e, MonadUnliftIO m) => m a -> Selector e -> m () -shouldThrow f s = withRunInIO $ \run -> H.shouldThrow (run f) s - --- | Return value on the `Right` and fail otherwise. Lifted version of `H.expectRight`. -expectRight :: (HasCallStack, Show a, MonadIO m) => Either a b -> m b -expectRight (Right r) = pure $! r -expectRight (Left l) = assertFailure $ "Expected Right, got Left:\n" <> show l - --- | Same as `expectRightDeep`, but discards the result -expectRightDeep_ :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m () -expectRightDeep_ = void . expectRightDeep - --- | Same as `expectRight`, but also evaluate the returned value to NF -expectRightDeep :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m b -expectRightDeep = expectRight >=> evaluateDeep - -- | Same as `expectRight`, but use `ToExpr` instead of `Show` expectRightExpr :: (HasCallStack, ToExpr a, MonadIO m) => Either a b -> m b expectRightExpr (Right r) = pure $! r @@ -287,27 +174,10 @@ expectRightExpr (Left l) = assertFailure $ "Expected Right, got Left:\n" <> show expectRightDeepExpr :: (HasCallStack, ToExpr a, NFData b, MonadIO m) => Either a b -> m b expectRightDeepExpr = expectRightExpr >=> evaluateDeep --- | Same as `shouldBe`, except it checks that the value is `Right` -shouldBeRight :: (HasCallStack, Show a, Show b, Eq b, MonadIO m) => Either a b -> b -> m () -shouldBeRight e x = expectRight e >>= (`shouldBe` x) - -- | Same as `shouldBeExpr`, except it checks that the value is `Right` shouldBeRightExpr :: (HasCallStack, ToExpr a, Eq b, ToExpr b, MonadIO m) => Either a b -> b -> m () shouldBeRightExpr e x = expectRightExpr e >>= (`shouldBeExpr` x) --- | Return value on the `Left` and fail otherwise -expectLeft :: (HasCallStack, Show b, MonadIO m) => Either a b -> m a -expectLeft (Left l) = pure $! l -expectLeft (Right r) = assertFailure $ "Expected Left, got Right:\n" <> show r - --- | Same as `expectLeftDeep`, but discards the result -expectLeftDeep_ :: (HasCallStack, MonadIO m, Show b, NFData a) => Either a b -> m () -expectLeftDeep_ = void . expectLeftDeep - --- | Same as `expectLeft`, but also evaluate the returned value to NF -expectLeftDeep :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m a -expectLeftDeep = expectLeft >=> evaluateDeep - -- | Same as `expectLeft`, but use `ToExpr` instead of `Show` expectLeftExpr :: (HasCallStack, ToExpr b, MonadIO m) => Either a b -> m a expectLeftExpr (Left l) = pure $! l @@ -317,138 +187,12 @@ expectLeftExpr (Right r) = assertFailure $ "Expected Left, got Right:\n" <> show expectLeftDeepExpr :: (HasCallStack, ToExpr b, NFData a, MonadIO m) => Either a b -> m a expectLeftDeepExpr = expectLeftExpr >=> evaluateDeep --- | Same as `shouldBe`, except it checks that the value is `Left` -shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b, MonadIO m) => Either a b -> a -> m () -shouldBeLeft e x = expectLeft e >>= (`shouldBe` x) - -- | Same as `shouldBeExpr`, except it checks that the value is `Left` shouldBeLeftExpr :: (HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) => Either a b -> a -> m () shouldBeLeftExpr e x = expectLeftExpr e >>= (`shouldBeExpr` x) -expectJust :: (HasCallStack, MonadIO m) => Maybe a -> m a -expectJust (Just x) = pure x -expectJust Nothing = assertFailure "Expected Just, got Nothing" - expectNothingExpr :: (HasCallStack, MonadIO m, ToExpr a) => Maybe a -> m () expectNothingExpr (Just x) = assertFailure $ "Expected Nothing, got Just:\n" <> showExpr x expectNothingExpr Nothing = pure () - ---------------------------- --- MonadGen alternatives -- ---------------------------- - -arbitrary :: (Arbitrary a, MonadGen m) => m a -arbitrary = liftGen H.arbitrary - ---------------------------------------------------------------------------- --- This interface will be defined in the next major version of `random` --- ---------------------------------------------------------------------------- - -class R.StatefulGen g m => HasStatefulGen g m | m -> g where - askStatefulGen :: m g - -class HasGenEnv env g | env -> g where - getGenEnv :: env -> g - -instance - (HasGenEnv env g, R.StatefulGen g (ReaderT env m), Monad m) => - HasStatefulGen g (ReaderT env m) - where - askStatefulGen = asks getGenEnv - -class HasSubState s where - type SubState s :: Type - getSubState :: s -> SubState s - getSubState = getConst . subStateL Const - setSubState :: s -> SubState s -> s - setSubState s a = runIdentity $ subStateL (const $ Identity a) s - subStateL :: Functor f => (SubState s -> f (SubState s)) -> (s -> f s) - subStateL k s = setSubState s <$> k (getSubState s) - {-# MINIMAL subStateL | getSubState, setSubState #-} - -setSubStateM :: (HasSubState s, MonadState s m) => SubState s -> m () -setSubStateM s = subStateM $ const ((), s) -{-# INLINE setSubStateM #-} - --- | Modify the sub-state and return a value, using the supplied function. --- Similar to the `state` method of `MonadState`. -subStateM :: (HasSubState s, MonadState s m) => (SubState s -> (a, SubState s)) -> m a -subStateM = state . subStateL -- Uses (a,) as the functor for subStateL -{-# INLINE subStateM #-} - -uniformM :: - ( HasStatefulGen g m - , R.Uniform a - ) => - m a -uniformM = askStatefulGen >>= R.uniformM -{-# INLINE uniformM #-} - -uniformRM :: - ( HasStatefulGen g m - , R.UniformRange a - ) => - (a, a) -> - m a -uniformRM r = askStatefulGen >>= R.uniformRM r -{-# INLINE uniformRM #-} - -uniformListM :: - ( HasStatefulGen g m - , R.Uniform a - ) => - Int -> - m [a] -uniformListM n = askStatefulGen >>= R.uniformListM n -{-# INLINE uniformListM #-} - -uniformListRM :: - ( HasStatefulGen g m - , R.UniformRange a - ) => - (a, a) -> - Int -> - m [a] -uniformListRM r n = askStatefulGen >>= replicateM n . R.uniformRM r -{-# INLINE uniformListRM #-} - -uniformByteStringM :: HasStatefulGen a m => Int -> m ByteString -uniformByteStringM n = askStatefulGen >>= R.uniformByteStringM n -{-# INLINE uniformByteStringM #-} - -uniformShortByteStringM :: HasStatefulGen a m => Int -> m ShortByteString -uniformShortByteStringM n = askStatefulGen >>= R.uniformShortByteString n -{-# INLINE uniformShortByteStringM #-} - -data StateGenM s = StateGenM - -newtype StateGen s = StateGen {unStateGen :: s} - deriving (Eq, Ord, Show, R.RandomGen, Storable, NFData) - -instance HasSubState (StateGen g) where - type SubState (StateGen g) = g - getSubState (StateGen g) = g - {-# INLINE getSubState #-} - setSubState _ = StateGen - {-# INLINE setSubState #-} - -instance - (HasSubState s, R.RandomGen (SubState s), MonadState s m) => - R.StatefulGen (StateGenM s) m - where - uniformWord32R r _ = subStateM (R.genWord32R r) - {-# INLINE uniformWord32R #-} - uniformWord64R r _ = subStateM (R.genWord64R r) - {-# INLINE uniformWord64R #-} - uniformWord8 _ = subStateM R.genWord8 - {-# INLINE uniformWord8 #-} - uniformWord16 _ = subStateM R.genWord16 - {-# INLINE uniformWord16 #-} - uniformWord32 _ = subStateM R.genWord32 - {-# INLINE uniformWord32 #-} - uniformWord64 _ = subStateM R.genWord64 - {-# INLINE uniformWord64 #-} - uniformShortByteString n _ = subStateM (R.genShortByteString n) - {-# INLINE uniformShortByteString #-}