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

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

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 (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"
    [ Proof ShelleyEra -> TestTree
forall {era}.
(Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 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), EraTest era,
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f Proof ShelleyEra
Shelley
    , Proof AllegraEra -> TestTree
forall {era}.
(Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 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), EraTest era,
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f Proof AllegraEra
Allegra
    , Proof MaryEra -> TestTree
forall {era}.
(Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 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), EraTest era,
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f Proof MaryEra
Mary
    , Proof AlonzoEra -> TestTree
forall {era}.
(Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 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), EraTest era,
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f Proof AlonzoEra
Alonzo
    , Proof BabbageEra -> TestTree
forall {era}.
(Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 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), EraTest era,
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f Proof BabbageEra
Babbage
    , Proof ConwayEra -> TestTree
forall {era}.
(Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 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), EraTest era,
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f Proof ConwayEra
Conway
    ]
  where
    f :: Proof era -> TestTree
f Proof era
proof = Proof era -> Int -> GenSize -> TestTree
forall era.
(Reflect era, HasTrace (MOCKCHAIN era) (Gen1 era)) =>
Proof era -> Int -> GenSize -> TestTree
testThunks Proof era
proof Int
100 GenSize
forall a. Default a => a
def

testThunks ::
  forall era.
  ( Reflect era
  , HasTrace (MOCKCHAIN era) (Gen1 era)
  ) =>
  Proof era ->
  Int ->
  GenSize ->
  TestTree
testThunks :: forall era.
(Reflect era, HasTrace (MOCKCHAIN era) (Gen1 era)) =>
Proof era -> Int -> GenSize -> TestTree
testThunks Proof era
proof Int
numTx GenSize
gensize =
  TestName -> Gen (IO ()) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty (Proof era -> TestName
forall a. Show a => a -> TestName
show Proof era
proof 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
$
    Proof era
-> Int
-> GenSize
-> (MockChainState era -> MockChainState era -> IO ())
-> Gen (IO ())
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 <- Proof era -> MockChainState era -> IO (Maybe ThunkInfo)
forall era. Proof era -> MockChainState era -> IO (Maybe ThunkInfo)
noThunksGen Proof era
proof 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 ()
      )