{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module Test.Cardano.Ledger.NoThunks (
  test,
) where

import Control.State.Transition.Extended (STS)
import Data.Default (def)
import Test.Cardano.Ledger.Generic.GenState (GenSize)
import Test.Cardano.Ledger.Generic.MockChain (MOCKCHAIN, noThunksGen)
import Test.Cardano.Ledger.Generic.Proof (Proof (..), Reflect)
import Test.Cardano.Ledger.Generic.Trace (traceProp)
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}.
(Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo, Reflect era,
 Embed (EraRule "TICK" era) (MOCKCHAIN era),
 Embed (EraRule "LEDGERS" era) (MOCKCHAIN era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Embed (EraRule "RUPD" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f forall a b. (a -> b) -> a -> b
$ Proof BabbageEra
Babbage
    , forall {era}.
(Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo, Reflect era,
 Embed (EraRule "TICK" era) (MOCKCHAIN era),
 Embed (EraRule "LEDGERS" era) (MOCKCHAIN era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Embed (EraRule "RUPD" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f forall a b. (a -> b) -> a -> b
$ Proof AlonzoEra
Alonzo
    , forall {era}.
(Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo, Reflect era,
 Embed (EraRule "TICK" era) (MOCKCHAIN era),
 Embed (EraRule "LEDGERS" era) (MOCKCHAIN era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Embed (EraRule "RUPD" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f forall a b. (a -> b) -> a -> b
$ Proof AllegraEra
Allegra
    , forall {era}.
(Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo, Reflect era,
 Embed (EraRule "TICK" era) (MOCKCHAIN era),
 Embed (EraRule "LEDGERS" era) (MOCKCHAIN era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Embed (EraRule "RUPD" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f forall a b. (a -> b) -> a -> b
$ Proof MaryEra
Mary
    , forall {era}.
(Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo, Reflect era,
 Embed (EraRule "TICK" era) (MOCKCHAIN era),
 Embed (EraRule "LEDGERS" era) (MOCKCHAIN era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Embed (EraRule "RUPD" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f forall a b. (a -> b) -> a -> b
$ Proof ShelleyEra
Shelley
    ]
  where
    f :: Proof era -> TestTree
f Proof era
proof = forall era.
(Reflect era, STS (MOCKCHAIN era)) =>
Proof era -> Int -> GenSize -> TestTree
testThunks Proof era
proof Int
100 forall a. Default a => a
def

testThunks ::
  forall era.
  ( Reflect era
  , STS (MOCKCHAIN era)
  ) =>
  Proof era ->
  Int ->
  GenSize ->
  TestTree
testThunks :: forall era.
(Reflect era, STS (MOCKCHAIN era)) =>
Proof era -> Int -> GenSize -> TestTree
testThunks Proof era
proof Int
numTx GenSize
gensize =
  forall a. Testable a => TestName -> a -> TestTree
testProperty (forall a. Show a => a -> TestName
show Proof era
proof forall a. [a] -> [a] -> [a]
++ TestName
" era. Trace length = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> TestName
show Int
numTx) forall a b. (a -> b) -> a -> b
$
    forall era prop.
(Reflect era, HasTrace (MOCKCHAIN era) (Gen1 era)) =>
Proof era
-> Int
-> GenSize
-> (MockChainState era -> MockChainState era -> prop)
-> Gen prop
traceProp
      Proof era
proof
      Int
numTx
      GenSize
gensize
      ( \MockChainState era
_ !MockChainState era
trc -> do
          Maybe ThunkInfo
nt <- forall era. Proof era -> MockChainState era -> IO (Maybe ThunkInfo)
noThunksGen Proof era
proof MockChainState era
trc
          case Maybe ThunkInfo
nt of
            Just ThunkInfo
x -> forall a. HasCallStack => TestName -> a
error forall a b. (a -> b) -> a -> b
$ TestName
"Thunks present: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> TestName
show ThunkInfo
x
            Maybe ThunkInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      )

-- main :: IO ()
-- main = defaultMain test