{-# LANGUAGE DerivingStrategies #-}
{-# 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 qualified Cardano.Ledger.BaseTypes as L
import qualified Cardano.Ledger.Shelley.API.Types as L
import Data.MemPack
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.Binary.Twiddle ()
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Babbage.Binary.Twiddle ()
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()
import Test.Consensus.Shelley.Generators ()
import Test.Consensus.Shelley.MockCrypto (CanMock)
import Test.LedgerTables
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup String
"LedgerTables"
    ([TestTree] -> TestTree)
-> (NP Proxy (CardanoShelleyEras StandardCrypto) -> [TestTree])
-> NP Proxy (CardanoShelleyEras StandardCrypto)
-> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (TxId -> TxIx -> TxIx -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Serializing BigEndianTxIn preserves order" TxId -> TxIx -> TxIx -> Property
testBigEndianTxInPreservesOrder TestTree -> [TestTree] -> [TestTree]
forall a. a -> [a] -> [a]
:)
    ([TestTree] -> [TestTree])
-> (NP Proxy (CardanoShelleyEras StandardCrypto) -> [TestTree])
-> NP Proxy (CardanoShelleyEras StandardCrypto)
-> [TestTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Serializing TxIn fails to preserve order" ((TxId -> TxIx -> TxIx -> Property) -> Property
forall prop. Testable prop => prop -> Property
expectFailure TxId -> TxIx -> TxIx -> Property
testTxInPreservesOrder) TestTree -> [TestTree] -> [TestTree]
forall a. a -> [a] -> [a]
:)
    ([TestTree] -> [TestTree])
-> (NP Proxy (CardanoShelleyEras StandardCrypto) -> [TestTree])
-> NP Proxy (CardanoShelleyEras StandardCrypto)
-> [TestTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (TxIn -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"BigEndianTxIn roundtrips" TxIn -> Property
testBigEndianRoundtrips TestTree -> [TestTree] -> [TestTree]
forall a. a -> [a] -> [a]
:)
    ([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
_ =
    String -> [TestTree] -> TestTree
testGroup
      (forall era. Era era => String
L.eraName @(ShelleyBlockLedgerEra blk))
      [ String
-> (LedgerState blk EmptyMK
    -> LedgerState blk ValuesMK -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Stowable laws" (forall blk.
(HasLedgerTables (LedgerState blk),
 CanStowLedgerTables (LedgerState blk)) =>
LedgerState blk EmptyMK -> LedgerState blk ValuesMK -> Property
prop_stowable_laws @blk)
      , String
-> (LedgerState blk EmptyMK
    -> LedgerTables (LedgerState blk) ValuesMK -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"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

testBigEndianTxInPreservesOrder :: L.TxId -> L.TxIx -> L.TxIx -> Property
testBigEndianTxInPreservesOrder :: TxId -> TxIx -> TxIx -> Property
testBigEndianTxInPreservesOrder TxId
txid TxIx
txix1 TxIx
txix2 =
  let b1 :: ByteString
b1 = BigEndianTxIn -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString (TxIn -> BigEndianTxIn
BigEndianTxIn (TxIn -> BigEndianTxIn) -> TxIn -> BigEndianTxIn
forall a b. (a -> b) -> a -> b
$ TxId -> TxIx -> TxIn
L.TxIn TxId
txid TxIx
txix1)
      b2 :: ByteString
b2 = BigEndianTxIn -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString (TxIn -> BigEndianTxIn
BigEndianTxIn (TxIn -> BigEndianTxIn) -> TxIn -> BigEndianTxIn
forall a b. (a -> b) -> a -> b
$ TxId -> TxIx -> TxIn
L.TxIn TxId
txid TxIx
txix2)
   in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ByteString -> String
forall a. Show a => a -> String
show ByteString
b1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
b2) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
b1 ByteString
b2 Ordering -> Ordering -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxIx -> TxIx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TxIx
txix1 TxIx
txix2

testBigEndianRoundtrips :: L.TxIn -> Property
testBigEndianRoundtrips :: TxIn -> Property
testBigEndianRoundtrips TxIn
txin =
  case ByteArray -> Either SomeError TxIn
forall a b.
(MemPack a, Buffer b, HasCallStack) =>
b -> Either SomeError a
unpack (TxIn -> ByteArray
forall a. (MemPack a, HasCallStack) => a -> ByteArray
pack TxIn
txin) of
    Left SomeError
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"unpack failed with error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeError -> String
forall a. Show a => a -> String
show SomeError
err) Bool
False
    Right TxIn
v -> TxIn
v TxIn -> TxIn -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxIn
txin

testTxInPreservesOrder :: L.TxId -> L.TxIx -> L.TxIx -> Property
testTxInPreservesOrder :: TxId -> TxIx -> TxIx -> Property
testTxInPreservesOrder TxId
txid TxIx
txix1 TxIx
txix2 =
  let b1 :: ByteString
b1 = TxIn -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString (TxId -> TxIx -> TxIn
L.TxIn TxId
txid TxIx
txix1)
      b2 :: ByteString
b2 = TxIn -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString (TxId -> TxIx -> TxIn
L.TxIn TxId
txid TxIx
txix2)
   in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ByteString -> String
forall a. Show a => a -> String
show ByteString
b1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
b2) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
b1 ByteString
b2 Ordering -> Ordering -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxIx -> TxIx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TxIx
txix1 TxIx
txix2