{-# 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"
    [ Proof BabbageEra -> TestTree
forall {era}.
(Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 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 "RUPD" era) (ShelleyTICK era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f (Proof BabbageEra -> TestTree) -> Proof BabbageEra -> TestTree
forall a b. (a -> b) -> a -> b
$ Proof BabbageEra
Babbage
    , Proof AlonzoEra -> TestTree
forall {era}.
(Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 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 "RUPD" era) (ShelleyTICK era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f (Proof AlonzoEra -> TestTree) -> Proof AlonzoEra -> TestTree
forall a b. (a -> b) -> a -> b
$ Proof AlonzoEra
Alonzo
    , Proof AllegraEra -> TestTree
forall {era}.
(Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 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 "RUPD" era) (ShelleyTICK era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f (Proof AllegraEra -> TestTree) -> Proof AllegraEra -> TestTree
forall a b. (a -> b) -> a -> b
$ Proof AllegraEra
Allegra
    , Proof MaryEra -> TestTree
forall {era}.
(Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 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 "RUPD" era) (ShelleyTICK era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f (Proof MaryEra -> TestTree) -> Proof MaryEra -> TestTree
forall a b. (a -> b) -> a -> b
$ Proof MaryEra
Mary
    , Proof ShelleyEra -> TestTree
forall {era}.
(Signal (EraRule "LEDGER" era) ~ Tx era,
 Signal (EraRule "TICK" era) ~ SlotNo,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Signal (EraRule "RUPD" era) ~ SlotNo,
 Signal (EraRule "NEWEPOCH" era) ~ EpochNo,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 State (EraRule "TICK" era) ~ NewEpochState era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate,
 State (EraRule "NEWEPOCH" era) ~ NewEpochState era,
 BaseM (EraRule "TICK" era) ~ ShelleyBase,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 BaseM (EraRule "RUPD" era) ~ ShelleyBase,
 BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Environment (EraRule "TICK" era) ~ (),
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Environment (EraRule "RUPD" era) ~ RupdEnv era,
 Environment (EraRule "NEWEPOCH" era) ~ (),
 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 "RUPD" era) (ShelleyTICK era),
 Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era),
 Show (PredicateFailure (EraRule "LEDGER" era)),
 Eq (PredicateFailure (EraRule "LEDGER" era))) =>
Proof era -> TestTree
f (Proof ShelleyEra -> TestTree) -> Proof ShelleyEra -> TestTree
forall a b. (a -> b) -> a -> b
$ Proof ShelleyEra
Shelley
    ]
  where
    f :: Proof era -> TestTree
f Proof era
proof = Proof era -> Int -> GenSize -> TestTree
forall era.
(Reflect era, STS (MOCKCHAIN era)) =>
Proof era -> Int -> GenSize -> TestTree
testThunks Proof era
proof Int
100 GenSize
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 =
  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 ()
      )

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