{-# 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.Class (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}.
(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 (EraCrypto 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,
 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 StandardCrypto)
Babbage
    , forall {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 (EraCrypto 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,
 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 StandardCrypto)
Alonzo
    , forall {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 (EraCrypto 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,
 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 StandardCrypto)
Allegra
    , forall {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 (EraCrypto 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,
 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 StandardCrypto)
Mary
    , forall {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 (EraCrypto 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,
 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 StandardCrypto)
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