{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Byron.Spec.Ledger.AbstractSize.Properties (testTxHasTypeReps, testProperty) where

import Byron.Spec.Ledger.Core hiding ((<|))
import Byron.Spec.Ledger.STS.UTXOW (UTXOW)
import Byron.Spec.Ledger.UTxO
import Data.AbstractSize
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Sequence (empty, (<|), (><))
import qualified Data.Sequence as Seq
import Data.Typeable (TypeRep, Typeable, typeOf)
import Hedgehog (MonadTest, Property, forAll, property, withTests, (===))
import Hedgehog.Internal.Property (PropertyName (..))
import Numeric.Natural (Natural)
import Test.Control.State.Transition.Generator (trace)
import Test.Control.State.Transition.Trace (TraceOrder (OldestFirst), traceSignals)
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, testCase, (@?=))
import Test.Tasty.Hedgehog hiding (testProperty)

-- | testProperty has been deprecated. We make our own version here.
testProperty :: TestName -> Property -> TestTree
testProperty :: TestName -> Property -> TestTree
testProperty TestName
s Property
p = TestName -> PropertyName -> Property -> TestTree
testPropertyNamed TestName
s (TestName -> PropertyName
Hedgehog.Internal.Property.PropertyName TestName
s) Property
p

--------------------------------------------------------------------------------
-- Example HasTypeReps.typeReps for TxIn, Tx
--------------------------------------------------------------------------------

aTx :: TxBody
aTx :: TxBody
aTx = TxBody
forall a. HasCallStack => a
undefined

aTxId :: TxId
aTxId :: TxId
aTxId = Hash -> TxId
TxId (TxBody -> Hash
forall a. HasHash a => a -> Hash
hash TxBody
aTx)

-- | 'TxIn' has a generic instance for 'HasTypeReps', which recursively adds
--   'typeReps' for all types within 'TxIn'.
exampleTypeRepsTxIn :: Assertion
exampleTypeRepsTxIn :: Assertion
exampleTypeRepsTxIn =
  let txIn :: TxIn
txIn = TxId -> Natural -> TxIn
TxIn TxId
aTxId Natural
0
   in TxIn -> Seq TypeRep
forall a. HasTypeReps a => a -> Seq TypeRep
typeReps TxIn
txIn
        Seq TypeRep -> Seq TypeRep -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= TxIn -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (TxIn
forall a. HasCallStack => a
undefined :: TxIn)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| TxId -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (TxId
forall a. HasCallStack => a
undefined :: TxId)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| Hash -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Hash
forall a. HasCallStack => a
undefined :: Hash)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| Maybe Int -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Maybe Int
forall a. HasCallStack => a
undefined :: Maybe Int)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| Int -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Int
forall a. HasCallStack => a
undefined :: Int)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| Natural -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Natural
forall a. HasCallStack => a
undefined :: Natural)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| Seq TypeRep
forall a. Seq a
empty

-- | A 'TxWits' term may contain multiple inputs/outputs/witnesses.
--   In this example, we have 2 inputs and show how the 'typeReps' for
--   'TxIn' is repeated twice.
exampleTypeRepsTx :: Assertion
exampleTypeRepsTx :: Assertion
exampleTypeRepsTx =
  let (TxIn
in0, TxIn
in1) = (TxId -> Natural -> TxIn
TxIn TxId
aTxId Natural
0, TxId -> Natural -> TxIn
TxIn TxId
aTxId Natural
1)
      outs :: [a]
outs = []
      wits :: [a]
wits = []
      tx :: Tx
tx = TxBody -> [Wit] -> Tx
Tx ([TxIn] -> [TxOut] -> TxBody
TxBody [TxIn
in0, TxIn
in1] [TxOut]
forall a. [a]
outs) [Wit]
forall a. [a]
wits
   in Tx -> Seq TypeRep
forall a. HasTypeReps a => a -> Seq TypeRep
typeReps Tx
tx
        Seq TypeRep -> Seq TypeRep -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Tx -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Tx
forall a. HasCallStack => a
undefined :: Tx)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| TxBody -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (TxBody
forall a. HasCallStack => a
undefined :: TxBody)
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| [TxIn] -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf ([TxIn]
forall a. HasCallStack => a
undefined :: [TxIn])
          TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. a -> Seq a -> Seq a
<| TxIn -> Seq TypeRep
forall a. HasTypeReps a => a -> Seq TypeRep
typeReps TxIn
in0
          Seq TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. Seq a -> Seq a -> Seq a
>< TxIn -> Seq TypeRep
forall a. HasTypeReps a => a -> Seq TypeRep
typeReps TxIn
in1
          Seq TypeRep -> Seq TypeRep -> Seq TypeRep
forall a. Seq a -> Seq a -> Seq a
>< ( [TypeRep] -> Seq TypeRep
forall a. [a] -> Seq a
Seq.fromList
                 [ [TxOut] -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf ([TxOut]
forall a. HasCallStack => a
undefined :: [TxOut])
                 , [Wit] -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf ([Wit]
forall a. HasCallStack => a
undefined :: [Wit])
                 ]
             )

--------------------------------------------------------------------------------
-- Properties of abstractSize of TxWits / TxIn /TxOut / Wit
--------------------------------------------------------------------------------

-- | Make a singleton cost of "1" for the given term's type
mkCost :: forall a. Typeable a => Map TypeRep Size
mkCost :: forall a. Typeable a => Map TypeRep Int
mkCost = TypeRep -> Int -> Map TypeRep Int
forall k a. k -> a -> Map k a
Map.singleton (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
forall a. HasCallStack => a
undefined :: a)) Int
1

-- | Tests that the size of a 'TxWits' term, computed with the combined costs
--   of 'TxIn/TxOut/Wit', is the sum of costs of all 'TxIn/TxOut/Wit' contained
--   in the 'TxWits'.
propSumOfSizesTx ::
  MonadTest m => Tx -> m ()
propSumOfSizesTx :: forall (m :: * -> *). MonadTest m => Tx -> m ()
propSumOfSizesTx Tx
txw =
  Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (Map TypeRep Int
txInCosts Map TypeRep Int -> Map TypeRep Int -> Map TypeRep Int
forall a. Semigroup a => a -> a -> a
<> Map TypeRep Int
txOutCosts Map TypeRep Int -> Map TypeRep Int -> Map TypeRep Int
forall a. Semigroup a => a -> a -> a
<> Map TypeRep Int
witCosts) Tx
txw
    Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Map TypeRep Int -> TxBody -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize Map TypeRep Int
txInCosts (Tx -> TxBody
body Tx
txw)
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map TypeRep Int -> TxBody -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize Map TypeRep Int
txOutCosts (Tx -> TxBody
body Tx
txw)
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map TypeRep Int -> [Wit] -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize Map TypeRep Int
witCosts (Tx -> [Wit]
witnesses Tx
txw)
  where
    txInCosts :: Map TypeRep Size
    txInCosts :: Map TypeRep Int
txInCosts = [Map TypeRep Int] -> Map TypeRep Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [forall a. Typeable a => Map TypeRep Int
mkCost @TxIn, forall a. Typeable a => Map TypeRep Int
mkCost @TxId, forall a. Typeable a => Map TypeRep Int
mkCost @Hash]

    txOutCosts :: Map TypeRep Size
    txOutCosts :: Map TypeRep Int
txOutCosts = [Map TypeRep Int] -> Map TypeRep Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [forall a. Typeable a => Map TypeRep Int
mkCost @TxOut, forall a. Typeable a => Map TypeRep Int
mkCost @Addr, forall a. Typeable a => Map TypeRep Int
mkCost @VKey, forall a. Typeable a => Map TypeRep Int
mkCost @Lovelace]

    witCosts :: Map TypeRep Size
    witCosts :: Map TypeRep Int
witCosts = [Map TypeRep Int] -> Map TypeRep Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [forall a. Typeable a => Map TypeRep Int
mkCost @Wit, forall a. Typeable a => Map TypeRep Int
mkCost @VKey, forall a. Typeable a => Map TypeRep Int
mkCost @(Sig TxBody)]

-- | A TxWits contains multiple inputs, outputs and witnesses.
--   This property tests that
--   - the abstractSize of TxWits varies with the number of items
--   - the combined cost is the sum of individual costs
--   - types that are shared (e.g. VKey appears in both TxOut and Wit)
--     should be counted for each appearance
propMultipleOfSizes ::
  MonadTest m => Tx -> m ()
propMultipleOfSizes :: forall (m :: * -> *). MonadTest m => Tx -> m ()
propMultipleOfSizes Tx
txw =
  let body_ :: TxBody
body_ = Tx -> TxBody
body Tx
txw
      wits_ :: [Wit]
wits_ = Tx -> [Wit]
witnesses Tx
txw
   in do
        -- we should account for each TxIn/TxId/Hash in a TxWits's size
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxIn) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxIn]
inputs TxBody
body_)
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxId) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxIn]
inputs TxBody
body_)
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Hash) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxIn]
inputs TxBody
body_)
        -- the combined cost is the sum of individual costs
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize ([Map TypeRep Int] -> Map TypeRep Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [forall a. Typeable a => Map TypeRep Int
mkCost @TxIn, forall a. Typeable a => Map TypeRep Int
mkCost @TxId, forall a. Typeable a => Map TypeRep Int
mkCost @Hash]) Tx
txw
          Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxIn) Tx
txw
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxId) Tx
txw
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Hash) Tx
txw

        -- we should account for each TxOut/Addr/Lovelace in a TxWits's size
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxOut) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_)
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Addr) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_)
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Lovelace) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_)
        -- the combined cost is the sum of individual costs
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize ([Map TypeRep Int] -> Map TypeRep Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [forall a. Typeable a => Map TypeRep Int
mkCost @TxOut, forall a. Typeable a => Map TypeRep Int
mkCost @Addr, forall a. Typeable a => Map TypeRep Int
mkCost @Lovelace]) Tx
txw
          Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxOut) Tx
txw
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Addr) Tx
txw
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Lovelace) Tx
txw

        -- we should account for each Wit/Sig in a TxWits's size
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Wit) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [Wit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Wit]
wits_
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @(Sig TxBody)) Tx
txw Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [Wit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Wit]
wits_
        -- the combined cost is the sum of individual costs
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize ([Map TypeRep Int] -> Map TypeRep Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [forall a. Typeable a => Map TypeRep Int
mkCost @Wit, forall a. Typeable a => Map TypeRep Int
mkCost @(Sig TxBody)]) Tx
txw
          Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Wit) Tx
txw
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @(Sig TxBody)) Tx
txw

        -- since Vkey appears in each input _and_ each witness, the size of
        -- TxWits should be the total number of inputs and wits
        Map TypeRep Int -> Tx -> Int
forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @VKey) Tx
txw
          Int -> Int -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Wit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Wit]
wits_

propTxAbstractSize :: Property
propTxAbstractSize :: Property
propTxAbstractSize =
  TestLimit -> Property -> Property
withTests TestLimit
50 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
      Trace UTXOW
tr <- Gen (Trace UTXOW) -> PropertyT IO (Trace UTXOW)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (forall s. HasTrace s => BaseEnv s -> Word64 -> Gen (Trace s)
trace @UTXOW () Word64
100)
      let txs :: [Tx]
txs = TraceOrder -> Trace UTXOW -> [Signal UTXOW]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
tr :: [Tx]
      (Tx -> PropertyT IO ()) -> [Tx] -> PropertyT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Tx -> PropertyT IO ()
forall (m :: * -> *). MonadTest m => Tx -> m ()
propSize [Tx]
txs
  where
    propSize :: Tx -> m ()
propSize Tx
txw = Tx -> m ()
forall (m :: * -> *). MonadTest m => Tx -> m ()
propSumOfSizesTx Tx
txw m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tx -> m ()
forall (m :: * -> *). MonadTest m => Tx -> m ()
propMultipleOfSizes Tx
txw

testTxHasTypeReps :: TestTree
testTxHasTypeReps :: TestTree
testTxHasTypeReps =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Test HasTypeReps instances"
    [ TestName -> Assertion -> TestTree
testCase TestName
"AbstractSize - example - TxIn" Assertion
exampleTypeRepsTxIn
    , TestName -> Assertion -> TestTree
testCase TestName
"AbstractSize - example - Tx" Assertion
exampleTypeRepsTx
    , TestName -> Property -> TestTree
testProperty TestName
"AbstractSize and HasTypeReps - Tx*" Property
propTxAbstractSize
    ]