{-# 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 ()
      )