{-# 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 = forall a. HasCallStack => a
undefined

aTxId :: TxId
aTxId :: TxId
aTxId = Hash -> TxId
TxId (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 forall a. HasTypeReps a => a -> Seq TypeRep
typeReps TxIn
txIn
        forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: TxIn)
          forall a. a -> Seq a -> Seq a
<| forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: TxId)
          forall a. a -> Seq a -> Seq a
<| forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: Hash)
          forall a. a -> Seq a -> Seq a
<| forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: Maybe Int)
          forall a. a -> Seq a -> Seq a
<| forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: Int)
          forall a. a -> Seq a -> Seq a
<| forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: Natural)
          forall a. a -> Seq a -> Seq a
<| 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] forall a. [a]
outs) forall a. [a]
wits
   in forall a. HasTypeReps a => a -> Seq TypeRep
typeReps Tx
tx
        forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: Tx)
          forall a. a -> Seq a -> Seq a
<| forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: TxBody)
          forall a. a -> Seq a -> Seq a
<| forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: [TxIn])
          forall a. a -> Seq a -> Seq a
<| forall a. HasTypeReps a => a -> Seq TypeRep
typeReps TxIn
in0
          forall a. Seq a -> Seq a -> Seq a
>< forall a. HasTypeReps a => a -> Seq TypeRep
typeReps TxIn
in1
          forall a. Seq a -> Seq a -> Seq a
>< ( forall a. [a] -> Seq a
Seq.fromList
                [ forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: [TxOut])
                , forall a. Typeable a => a -> TypeRep
typeOf (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 = forall k a. k -> a -> Map k a
Map.singleton (forall a. Typeable a => a -> TypeRep
typeOf (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 =
  forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (Map TypeRep Int
txInCosts forall a. Semigroup a => a -> a -> a
<> Map TypeRep Int
txOutCosts forall a. Semigroup a => a -> a -> a
<> Map TypeRep Int
witCosts) Tx
txw
    forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize Map TypeRep Int
txInCosts (Tx -> TxBody
body Tx
txw)
      forall a. Num a => a -> a -> a
+ forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize Map TypeRep Int
txOutCosts (Tx -> TxBody
body Tx
txw)
      forall a. Num a => a -> a -> a
+ 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 = 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 = 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 = 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
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxIn) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxIn]
inputs TxBody
body_)
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxId) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxIn]
inputs TxBody
body_)
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Hash) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxIn]
inputs TxBody
body_)
        -- the combined cost is the sum of individual costs
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (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
          forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxIn) Tx
txw
            forall a. Num a => a -> a -> a
+ forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxId) Tx
txw
            forall a. Num a => a -> a -> a
+ 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
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxOut) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_)
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Addr) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_)
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Lovelace) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_)
        -- the combined cost is the sum of individual costs
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (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
          forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @TxOut) Tx
txw
            forall a. Num a => a -> a -> a
+ forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Addr) Tx
txw
            forall a. Num a => a -> a -> a
+ 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
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Wit) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Wit]
wits_
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @(Sig TxBody)) Tx
txw forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Wit]
wits_
        -- the combined cost is the sum of individual costs
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (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
          forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @Wit) Tx
txw
            forall a. Num a => a -> a -> a
+ 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
        forall a. HasTypeReps a => Map TypeRep Int -> a -> Int
abstractSize (forall a. Typeable a => Map TypeRep Int
mkCost @VKey) Tx
txw
          forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody -> [TxOut]
outputs TxBody
body_) forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Wit]
wits_

propTxAbstractSize :: Property
propTxAbstractSize :: Property
propTxAbstractSize =
  TestLimit -> Property -> Property
withTests TestLimit
50 forall a b. (a -> b) -> a -> b
$
    HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
      Trace UTXOW
tr <- 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 = forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
tr :: [Tx]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadTest m => Tx -> m ()
propSize [Tx]
txs
  where
    propSize :: Tx -> m ()
propSize Tx
txw = forall (m :: * -> *). MonadTest m => Tx -> m ()
propSumOfSizesTx Tx
txw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
    ]