{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Byron.Spec.Ledger.UTxO.Properties where

import Byron.Spec.Ledger.Core (Lovelace, dom, unLovelace, (∩), (∪), (⋪), (◁))
import Byron.Spec.Ledger.STS.UTXO (UTxOState (UTxOState), pps, reserves, utxo)
import Byron.Spec.Ledger.STS.UTXOW (UTXOW)
import Byron.Spec.Ledger.UTxO (
  Tx (..),
  TxBody (TxBody),
  TxIn (TxIn),
  TxOut (TxOut),
  UTxO (UTxO),
  balance,
  body,
  inputs,
  outputs,
  pcMinFee,
  txins,
  txouts,
 )
import Control.Arrow (second, (***))
import Control.Monad (when)
import Data.Foldable as F (foldl', traverse_)
import qualified Data.Map.Strict as Map
import Data.Set (Set, empty, fromList, union)
import Hedgehog (
  MonadTest,
  Property,
  classify,
  cover,
  forAll,
  property,
  success,
  withTests,
  (===),
 )
import Lens.Micro ((&), (^.), _2)
import Lens.Micro.Extras (view)
import Test.Control.State.Transition.Generator (classifyTraceLength, trace, traceOfLength)
import Test.Control.State.Transition.Trace (
  Trace,
  TraceOrder (OldestFirst),
  firstAndLastState,
  preStatesAndSignals,
  traceEnv,
  traceLength,
  traceSignals,
  _traceInitState,
 )

--------------------------------------------------------------------------------
-- UTxO Properties
--------------------------------------------------------------------------------

-- | Check that the money is constant in the system.
moneyIsConstant :: Property
moneyIsConstant :: Property
moneyIsConstant = TestLimit -> Property -> Property
withTests TestLimit
300 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  (st0, st) <- Trace UTXOW -> (UTxOState, UTxOState)
Trace UTXOW -> (State UTXOW, State UTXOW)
forall s. Trace s -> (State s, State s)
firstAndLastState (Trace UTXOW -> (UTxOState, UTxOState))
-> PropertyT IO (Trace UTXOW)
-> PropertyT IO (UTxOState, UTxOState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
  reserves st0 + balance (utxo st0) === reserves st + balance (utxo st)

-- | Check that there is no double spending
noDoubleSpending :: Property
noDoubleSpending :: Property
noDoubleSpending = TestLimit -> Property -> Property
withTests TestLimit
300 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  t <- 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 UTxOState {utxo = utxo0} = _traceInitState t
      txs = Tx -> TxBody
body (Tx -> TxBody) -> [Tx] -> [TxBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceOrder -> Trace UTXOW -> [Signal UTXOW]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
t
  when (all (\TxBody
ti -> UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom (TxBody -> UTxO
txouts TxBody
ti) Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
∩ UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom UTxO
utxo0 Set TxIn -> Set TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== Set TxIn
forall a. Set a
empty) txs) $
    traverse_ (noCommonInputsTxs txs) (zip txs [0 ..])
  where
    noCommonInputsTxs :: MonadTest m => [TxBody] -> (TxBody, Int) -> m ()
    noCommonInputsTxs :: forall (m :: * -> *).
MonadTest m =>
[TxBody] -> (TxBody, Int) -> m ()
noCommonInputsTxs [TxBody]
txs (TxBody
tx, Int
i) =
      (TxBody -> m ()) -> [TxBody] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\TxBody
txj -> TxBody -> Set TxIn
txins' TxBody
txj Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
∩ TxBody -> Set TxIn
txins' TxBody
tx Set TxIn -> Set TxIn -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Set TxIn
forall a. Set a
empty) (Int -> [TxBody] -> [TxBody]
forall a. Int -> [a] -> [a]
take Int
i [TxBody]
txs)

    txins' :: TxBody -> Set TxIn
    txins' :: TxBody -> Set TxIn
txins' = [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
fromList ([TxIn] -> Set TxIn) -> (TxBody -> [TxIn]) -> TxBody -> Set TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody -> [TxIn]
txins

-- | Check that UTxO is outputs minus inputs
utxoDiff :: Property
utxoDiff :: Property
utxoDiff = TestLimit -> Property -> Property
withTests TestLimit
300 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  t <- 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 (utxo0, utxoSt) = (utxo *** utxo) . firstAndLastState $ t
      txs = Tx -> TxBody
body (Tx -> TxBody) -> [Tx] -> [TxBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceOrder -> Trace UTXOW -> [Signal UTXOW]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
t
  when (all (\TxBody
ti -> UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom (TxBody -> UTxO
txouts TxBody
ti) Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
∩ UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom UTxO
utxo0 Set TxIn -> Set TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== Set TxIn
forall a. Set a
empty) txs) $
    F.foldl' union' empty txs ⋪ (utxo0 ∪ allTxOuts txs) === utxoSt
  where
    union' :: Set TxIn -> TxBody -> Set TxIn
    union' :: Set TxIn -> TxBody -> Set TxIn
union' Set TxIn
s TxBody
tx = Set TxIn
s Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
`union` [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
fromList (TxBody -> [TxIn]
txins TxBody
tx)

    allTxOuts :: [TxBody] -> UTxO
    allTxOuts :: [TxBody] -> UTxO
allTxOuts [TxBody]
txs = (UTxO -> UTxO -> UTxO) -> UTxO -> [UTxO] -> UTxO
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' UTxO -> UTxO -> UTxO
forall m.
(Relation m, Ord (Domain m), Ord (Range m)) =>
m -> m -> m
(∪) (Map TxIn TxOut -> UTxO
UTxO Map TxIn TxOut
forall k a. Map k a
Map.empty) ((TxBody -> UTxO) -> [TxBody] -> [UTxO]
forall a b. (a -> b) -> [a] -> [b]
map TxBody -> UTxO
txouts [TxBody]
txs)

utxoAndTxoutsMustBeDisjoint :: Property
utxoAndTxoutsMustBeDisjoint :: Property
utxoAndTxoutsMustBeDisjoint = TestLimit -> Property -> Property
withTests TestLimit
300 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  t <- 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)
  traverse_ utxoAndTxoutsAreDisjoint $
    fmap (second body) $
      preStatesAndSignals OldestFirst t
  where
    utxoAndTxoutsAreDisjoint :: (UTxOState, TxBody) -> m ()
utxoAndTxoutsAreDisjoint (UTxOState {UTxO
utxo :: UTxOState -> UTxO
utxo :: UTxO
utxo}, TxBody
tx) =
      UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom UTxO
utxo Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
∩ UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom (TxBody -> UTxO
txouts TxBody
tx) Set TxIn -> Set TxIn -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Set TxIn
forall a. Monoid a => a
mempty

--------------------------------------------------------------------------------
-- Coverage guarantees for UTxO traces
--------------------------------------------------------------------------------

relevantCasesAreCovered :: Property
relevantCasesAreCovered :: Property
relevantCasesAreCovered = TestLimit -> Property -> Property
withTests TestLimit
400 (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
    let tl :: Word64
tl = Word64
300
    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)
traceOfLength @UTXOW () Word64
tl)
    let n :: Integer
        n = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Trace UTXOW -> Int
forall s. Trace s -> Int
traceLength Trace UTXOW
tr

    when (n > 0) $ do
      let ss = TraceOrder -> Trace UTXOW -> [(State UTXOW, Signal UTXOW)]
forall s. TraceOrder -> Trace s -> [(State s, Signal s)]
preStatesAndSignals TraceOrder
OldestFirst Trace UTXOW
tr
          txs = (Tx -> TxBody
body (Tx -> TxBody)
-> ((UTxOState, Tx) -> Tx) -> (UTxOState, Tx) -> TxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Tx (UTxOState, Tx) Tx -> (UTxOState, Tx) -> Tx
forall a s. Getting a s a -> s -> a
view Getting Tx (UTxOState, Tx) Tx
forall s t a b. Field2 s t a b => Lens s t a b
Lens (UTxOState, Tx) (UTxOState, Tx) Tx Tx
_2) ((UTxOState, Tx) -> TxBody) -> [(UTxOState, Tx)] -> [TxBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UTxOState, Tx)]
[(State UTXOW, Signal UTXOW)]
ss
          (avgInputs, avgOutputs) = avgInputsOutputs txs

      cover 20 "all txs have zero fee surplus" (avgFeeSurplus tr n == 0)
      cover 20 "avg. tx fee surplus (0,10]" (0 < avgFeeSurplus tr n && avgFeeSurplus tr n <= 10)
      cover 20 "avg. tx fee surplus (10,30]" (10 < avgFeeSurplus tr n && avgFeeSurplus tr n <= 30)
      cover 1 "avg. tx fee surplus (30,...)" (30 < avgFeeSurplus tr n)

      cover 20 "avg. nr. of tx inputs (1,5]" (1 <= avgInputs && avgInputs <= 5)
      cover 20 "avg. nr. of tx inputs (5,10]" (5 < avgInputs && avgInputs <= 10)

      cover 20 "avg. nr. of tx outputs (1,5]" (1 <= avgOutputs && avgOutputs <= 5)
      cover 20 "avg. nr. of tx outputs (5,10]" (5 < avgOutputs && avgOutputs <= 10)

      cover 80 "starting UTxO has no future inputs" (all (== empty) (futureInputs tr))
  where
    avgFeeSurplus :: Trace UTXOW -> Integer -> Int
    avgFeeSurplus :: Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n =
      TraceOrder -> Trace UTXOW -> [(State UTXOW, Signal UTXOW)]
forall s. TraceOrder -> Trace s -> [(State s, Signal s)]
preStatesAndSignals TraceOrder
OldestFirst Trace UTXOW
tr
        [(UTxOState, Tx)] -> ([(UTxOState, Tx)] -> [Integer]) -> [Integer]
forall a b. a -> (a -> b) -> b
& ((UTxOState, Tx) -> Integer) -> [(UTxOState, Tx)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map ((Tx -> Lovelace) -> (UTxOState, Tx) -> Integer
txFeeSurplus (PParams -> Tx -> Lovelace
pcMinFee PParams
pps_))
        [Integer] -> ([Integer] -> Integer) -> Integer
forall a b. a -> (a -> b) -> b
& [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        Integer -> (Integer -> Integer) -> Integer
forall a b. a -> (a -> b) -> b
& (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
n)
        Integer -> (Integer -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      where
        pps_ :: PParams
pps_ = UTxOEnv -> PParams
pps (Trace UTXOW
tr Trace UTXOW -> Getting UTxOEnv (Trace UTXOW) UTxOEnv -> UTxOEnv
forall s a. s -> Getting a s a -> a
^. Getting UTxOEnv (Trace UTXOW) UTxOEnv
(Environment UTXOW -> Const UTxOEnv (Environment UTXOW))
-> Trace UTXOW -> Const UTxOEnv (Trace UTXOW)
forall s (f :: * -> *).
Functor f =>
(Environment s -> f (Environment s)) -> Trace s -> f (Trace s)
traceEnv)
    txFeeSurplus :: (Tx -> Lovelace) -> (UTxOState, Tx) -> Integer
    txFeeSurplus :: (Tx -> Lovelace) -> (UTxOState, Tx) -> Integer
txFeeSurplus Tx -> Lovelace
txMinFee (UTxOState
st, Tx
txw) =
      Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
minFee
      where
        tx_ :: TxBody
tx_ = Tx -> TxBody
body Tx
txw
        utxo_ :: UTxO
utxo_ = UTxOState -> UTxO
utxo UTxOState
st
        fee :: Integer
fee = Lovelace -> Integer
unLovelace (Lovelace -> Integer) -> Lovelace -> Integer
forall a b. (a -> b) -> a -> b
$ UTxO -> Lovelace
balance (TxBody -> [TxIn]
txins TxBody
tx_ [Domain UTxO] -> UTxO -> UTxO
forall m (f :: * -> *).
(Relation m, Ord (Domain m), Foldable f) =>
f (Domain m) -> m -> m
forall (f :: * -> *).
(Ord (Domain UTxO), Foldable f) =>
f (Domain UTxO) -> UTxO -> UTxO
◁ UTxO
utxo_) Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
- UTxO -> Lovelace
balance (TxBody -> UTxO
txouts TxBody
tx_)
        minFee :: Integer
minFee = Lovelace -> Integer
unLovelace (Lovelace -> Integer) -> Lovelace -> Integer
forall a b. (a -> b) -> a -> b
$ Tx -> Lovelace
txMinFee Tx
txw
    futureInputs :: Trace UTXOW -> [Set TxIn]
    futureInputs :: Trace UTXOW -> [Set TxIn]
futureInputs Trace UTXOW
tr =
      let UTxOState {utxo :: UTxOState -> UTxO
utxo = UTxO
utxo0} = Trace UTXOW -> State UTXOW
forall s. Trace s -> State s
_traceInitState Trace UTXOW
tr
          txs :: [TxBody]
txs = Tx -> TxBody
body (Tx -> TxBody) -> [Tx] -> [TxBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceOrder -> Trace UTXOW -> [Signal UTXOW]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
tr
       in (\TxBody
ti -> UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom (TxBody -> UTxO
txouts TxBody
ti) Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
∩ UTxO -> Set (Domain UTxO)
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom UTxO
utxo0) (TxBody -> Set TxIn) -> [TxBody] -> [Set TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxBody]
txs

-- | Returns the average number of inputs and outputs for a list of transactions.
avgInputsOutputs :: [TxBody] -> (Double, Double)
avgInputsOutputs :: [TxBody] -> (Double, Double)
avgInputsOutputs [TxBody]
txs =
  case [TxBody] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxBody]
txs of
    Int
0 -> (Double
0, Double
0)
    Int
n ->
      ( Double
nrInputs Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      , Double
nrOutputs Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      )
  where
    nrInputs :: Double
nrInputs = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxIn] -> Int) -> (TxBody -> [TxIn]) -> TxBody -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody -> [TxIn]
inputs (TxBody -> Int) -> [TxBody] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxBody]
txs)
    nrOutputs :: Double
nrOutputs = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxOut] -> Int) -> (TxBody -> [TxOut]) -> TxBody -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody -> [TxOut]
outputs (TxBody -> Int) -> [TxBody] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxBody]
txs)

--------------------------------------------------------------------------------
-- Classified Traces (not included in CI test runs, but useful for development)
--------------------------------------------------------------------------------

-- To test the performance of the integrated shrinker for UTxO traces one could
-- replace the return statement of the 'UTXO' @transitionRule@ by:
--
-- >>> let xs =
-- >>>       if 2 < length (txins tx)
-- >>>       then drop 1 (txins tx)
-- >>>       else txins tx
-- >>> return $ UTxOState { utxo     = (xs ⋪ utxo) ∪ txouts tx
-- >>>                    , reserves = reserves + fee
-- >>>                    }
--
-- This should give a minimal counterexample of a trace with a signal
-- containing exactly 3 inputs, and only one output.
tracesAreClassified :: Property
tracesAreClassified :: Property
tracesAreClassified = TestLimit -> Property -> Property
withTests TestLimit
200 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  let (Word64
tl, Word64
step) = (Word64
100, Word64
10)
  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
tl)
  classifyTraceLength tr tl step

  let pparams = UTxOEnv -> PParams
pps (Trace UTXOW
tr Trace UTXOW -> Getting UTxOEnv (Trace UTXOW) UTxOEnv -> UTxOEnv
forall s a. s -> Getting a s a -> a
^. Getting UTxOEnv (Trace UTXOW) UTxOEnv
(Environment UTXOW -> Const UTxOEnv (Environment UTXOW))
-> Trace UTXOW -> Const UTxOEnv (Trace UTXOW)
forall s (f :: * -> *).
Functor f =>
(Environment s -> f (Environment s)) -> Trace s -> f (Trace s)
traceEnv)
      -- Transaction with one input, one output and no witnesses
      unitTx = TxBody -> [Wit] -> Tx
Tx ([TxIn] -> [TxOut] -> TxBody
TxBody [TxId -> Natural -> TxIn
TxIn TxId
forall a. HasCallStack => a
undefined Natural
0] [Addr -> Lovelace -> TxOut
TxOut Addr
forall a. HasCallStack => a
undefined Lovelace
100]) []
      unitTxFee = PParams -> Tx -> Lovelace
pcMinFee PParams
pparams Tx
unitTx
  classify "Unit transaction cost == 0" $ unitTxFee == 0
  classify "Unit transaction cost == 1" $ unitTxFee == 1
  classify "Unit transaction cost [2, 5)" $ 2 <= unitTxFee && unitTxFee < 5
  classify "Unit transaction cost [5, 10)" $ 5 <= unitTxFee && unitTxFee < 10
  classify "Unit transaction cost [10, 25)" $ 10 <= unitTxFee && unitTxFee < 25
  classify "Unit transaction cost [25, 100)" $ 25 <= unitTxFee && unitTxFee < 100
  classify "Unit transaction cost >= 100" $ 100 <= unitTxFee

  -- Classify the average number of inputs and outputs. Note that the intervals
  -- were arbitrarily determined, since in order to have a good partition of
  -- the interval [0, maximum possible number of inputs/outputs] we'd need to
  -- know how many addresses are being used in the trace generation.
  let actualTl = Trace UTXOW -> Int
forall s. Trace s -> Int
traceLength Trace UTXOW
tr
  when (0 < actualTl) $ do
    let txs = Tx -> TxBody
body (Tx -> TxBody) -> [Tx] -> [TxBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceOrder -> Trace UTXOW -> [Signal UTXOW]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
tr
        (avgInputs, avgOutputs) = avgInputsOutputs txs

    -- Classify the average number of inputs
    classify "avg nr. inputs == 0" $ (0 :: Double) == avgInputs
    classify "avg nr. inputs == 1" $ 1 == avgInputs
    classify "avg nr. inputs [2, 5)" $ 2 <= avgInputs && avgInputs < 5
    classify "avg nr. inputs [5, 10)" $ 5 <= avgInputs && avgInputs < 10
    classify "avg nr. inputs [10, 25)" $ 10 <= avgInputs && avgInputs < 25
    classify "avg nr. inputs [25, 100)" $ 25 <= avgInputs && avgInputs < 100
    classify ">= 100" $ 100 <= avgInputs
    -- Classify the average number of outputs
    classify "avg nr. outputs == 0" $ (0 :: Double) == avgOutputs
    classify "avg nr. outputs == 1" $ 1 == avgOutputs
    classify "avg nr. outputs [2, 5)" $ 2 <= avgOutputs && avgOutputs < 5
    classify "avg nr. outputs [5, 10)" $ 5 <= avgOutputs && avgOutputs < 10
    classify "avg nr. outputs [10, 25)" $ 10 <= avgOutputs && avgOutputs < 25
    classify "avg nr. outputs [25, 100)" $ 25 <= avgOutputs && avgOutputs < 100
    classify ">= 100" $ 100 <= avgOutputs
  success