{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.Shelley.LedgerTables (tests) where

import qualified Cardano.Ledger.Api.Era as L
import Data.Proxy
import Data.SOP.BasicFunctors
import Data.SOP.Constraint
import Data.SOP.Strict
import Ouroboros.Consensus.Cardano.Block (CardanoShelleyEras)
import Ouroboros.Consensus.Ledger.Tables
import Ouroboros.Consensus.Shelley.Eras
import Ouroboros.Consensus.Shelley.HFEras ()
import Ouroboros.Consensus.Shelley.Ledger
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Babbage.Serialisation.Generators ()
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Consensus.Shelley.Generators ()
import Test.Consensus.Shelley.MockCrypto (CanMock)
import Test.LedgerTables
import Test.Tasty
import Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"LedgerTables"
    ([TestTree] -> TestTree)
-> (NP Proxy (CardanoShelleyEras StandardCrypto) -> [TestTree])
-> NP Proxy (CardanoShelleyEras StandardCrypto)
-> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K TestTree) (CardanoShelleyEras StandardCrypto) -> [TestTree]
NP (K TestTree) (CardanoShelleyEras StandardCrypto)
-> CollapseTo NP TestTree
forall (xs :: [*]) a.
SListIN NP xs =>
NP (K a) xs -> CollapseTo NP a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
    (NP (K TestTree) (CardanoShelleyEras StandardCrypto) -> [TestTree])
-> (NP Proxy (CardanoShelleyEras StandardCrypto)
    -> NP (K TestTree) (CardanoShelleyEras StandardCrypto))
-> NP Proxy (CardanoShelleyEras StandardCrypto)
-> [TestTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy TestLedgerTables
-> (forall a. TestLedgerTables a => Proxy a -> K TestTree a)
-> NP Proxy (CardanoShelleyEras StandardCrypto)
-> NP (K TestTree) (CardanoShelleyEras StandardCrypto)
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @TestLedgerTables) (TestTree -> K TestTree a
forall k a (b :: k). a -> K a b
K (TestTree -> K TestTree a)
-> (Proxy a -> TestTree) -> Proxy a -> K TestTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TestTree
forall blk. TestLedgerTables blk => Proxy blk -> TestTree
f)
    (NP Proxy (CardanoShelleyEras StandardCrypto) -> TestTree)
-> NP Proxy (CardanoShelleyEras StandardCrypto) -> TestTree
forall a b. (a -> b) -> a -> b
$ ((forall a. Proxy a) -> NP Proxy (CardanoShelleyEras StandardCrypto)
forall (xs :: [*]) (f :: * -> *).
SListIN NP xs =>
(forall a. f a) -> NP f xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
hpure Proxy a
forall a. Proxy a
forall {k} (t :: k). Proxy t
Proxy :: NP Proxy (CardanoShelleyEras StandardCrypto))
 where
  f :: forall blk. TestLedgerTables blk => Proxy blk -> TestTree
  f :: forall blk. TestLedgerTables blk => Proxy blk -> TestTree
f Proxy blk
_ =
    TestName -> [TestTree] -> TestTree
testGroup
      (forall era. Era era => TestName
L.eraName @(ShelleyBlockLedgerEra blk))
      [ TestName
-> (LedgerState blk EmptyMK
    -> LedgerState blk ValuesMK -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"Stowable laws" (forall blk.
(HasLedgerTables (LedgerState blk),
 CanStowLedgerTables (LedgerState blk)) =>
LedgerState blk EmptyMK -> LedgerState blk ValuesMK -> Property
prop_stowable_laws @blk)
      , TestName
-> (LedgerState blk EmptyMK
    -> LedgerTables (LedgerState blk) ValuesMK -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"HasLedgerTables laws" (forall blk.
HasLedgerTables (LedgerState blk) =>
LedgerState blk EmptyMK
-> LedgerTables (LedgerState blk) ValuesMK -> Property
prop_hasledgertables_laws @blk)
      ]

class
  ( HasLedgerTables (LedgerState blk)
  , CanStowLedgerTables (LedgerState blk)
  , (Show `And` Arbitrary) (LedgerState blk EmptyMK)
  , (Show `And` Arbitrary) (LedgerState blk ValuesMK)
  , (Show `And` Arbitrary) (LedgerTables (LedgerState blk) ValuesMK)
  , L.Era (ShelleyBlockLedgerEra blk)
  ) =>
  TestLedgerTables blk

instance
  ( HasLedgerTables (LedgerState blk)
  , CanStowLedgerTables (LedgerState blk)
  , (Show `And` Arbitrary) (LedgerState blk EmptyMK)
  , (Show `And` Arbitrary) (LedgerState blk ValuesMK)
  , (Show `And` Arbitrary) (LedgerTables (LedgerState blk) ValuesMK)
  , L.Era (ShelleyBlockLedgerEra blk)
  ) =>
  TestLedgerTables blk

instance
  ( CanMock proto era
  , Arbitrary (LedgerState (ShelleyBlock proto era) EmptyMK)
  ) =>
  Arbitrary (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
  where
  arbitrary :: Gen (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
arbitrary = LedgerState (ShelleyBlock proto era) ValuesMK
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (ShelleyBlock proto era) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables (LedgerState (ShelleyBlock proto era) ValuesMK
 -> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
-> (LedgerState (ShelleyBlock proto era) EmptyMK
    -> LedgerState (ShelleyBlock proto era) ValuesMK)
-> LedgerState (ShelleyBlock proto era) EmptyMK
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) EmptyMK
-> LedgerState (ShelleyBlock proto era) ValuesMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l EmptyMK -> l ValuesMK
unstowLedgerTables (LedgerState (ShelleyBlock proto era) EmptyMK
 -> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
-> Gen (LedgerState (ShelleyBlock proto era) EmptyMK)
-> Gen
     (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (LedgerState (ShelleyBlock proto era) EmptyMK)
forall a. Arbitrary a => Gen a
arbitrary