{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.NoThunks ( test, ) where import Cardano.Ledger.Conway.Core (Era (..)) import Cardano.Ledger.Shelley.LedgerState (StashedAVVMAddresses) import NoThunks.Class (NoThunks) import Test.Cardano.Ledger.Generic.GenState (EraGenericGen, GenSize, defaultGenSize) import Test.Cardano.Ledger.Generic.MockChain (MOCKCHAIN, noThunksGen) import Test.Cardano.Ledger.Generic.Proof ( AllegraEra, AlonzoEra, BabbageEra, ConwayEra, MaryEra, ShelleyEra, ) import Test.Cardano.Ledger.Generic.Trace (Gen1, traceProp) import Test.Cardano.Ledger.Shelley.TreeDiff () import Test.Control.State.Transition.Trace.Generator.QuickCheck (HasTrace) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) test :: TestTree test :: TestTree test = TestName -> [TestTree] -> TestTree testGroup TestName "There are no unexpected thunks in MockChainState" [ forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => TestTree f @ShelleyEra , forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => TestTree f @AllegraEra , forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => TestTree f @MaryEra , forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => TestTree f @AlonzoEra , forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => TestTree f @BabbageEra , forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => TestTree f @ConwayEra ] where f :: forall era. ( HasTrace (MOCKCHAIN era) (Gen1 era) , EraGenericGen era , NoThunks (StashedAVVMAddresses era) ) => TestTree f :: forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => TestTree f = forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => Int -> GenSize -> TestTree testThunks @era Int 100 GenSize defaultGenSize testThunks :: forall era. ( HasTrace (MOCKCHAIN era) (Gen1 era) , EraGenericGen era , NoThunks (StashedAVVMAddresses era) ) => Int -> GenSize -> TestTree testThunks :: forall era. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era, NoThunks (StashedAVVMAddresses era)) => Int -> GenSize -> TestTree testThunks Int numTx GenSize gensize = TestName -> Gen (IO ()) -> TestTree forall a. Testable a => TestName -> a -> TestTree testProperty (forall era. Era era => TestName eraName @era TestName -> TestName -> TestName forall a. [a] -> [a] -> [a] ++ TestName " era. Trace length = " TestName -> TestName -> TestName forall a. [a] -> [a] -> [a] ++ Int -> TestName forall a. Show a => a -> TestName show Int numTx) (Gen (IO ()) -> TestTree) -> Gen (IO ()) -> TestTree forall a b. (a -> b) -> a -> b $ forall era prop. (HasTrace (MOCKCHAIN era) (Gen1 era), EraGenericGen era) => Int -> GenSize -> (MockChainState era -> MockChainState era -> prop) -> Gen prop traceProp @era Int numTx GenSize gensize ( \MockChainState era _ !MockChainState era trc -> do Maybe ThunkInfo nt <- MockChainState era -> IO (Maybe ThunkInfo) forall era. (EraTxOut era, NoThunks (GovState era), NoThunks (CertState era), NoThunks (InstantStake era), NoThunks (StashedAVVMAddresses era)) => MockChainState era -> IO (Maybe ThunkInfo) noThunksGen MockChainState era trc case Maybe ThunkInfo nt of Just ThunkInfo x -> TestName -> IO () forall a. HasCallStack => TestName -> a error (TestName -> IO ()) -> TestName -> IO () forall a b. (a -> b) -> a -> b $ TestName "Thunks present: " TestName -> TestName -> TestName forall a. Semigroup a => a -> a -> a <> ThunkInfo -> TestName forall a. Show a => a -> TestName show ThunkInfo x Maybe ThunkInfo Nothing -> () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () )