{-# 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