{-# 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  (UTxOState
st0, UTxOState
st) <- forall s. Trace s -> (State s, State s)
firstAndLastState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
  UTxOState -> Lovelace
reserves UTxOState
st0 forall a. Num a => a -> a -> a
+ UTxO -> Lovelace
balance (UTxOState -> UTxO
utxo UTxOState
st0) forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== UTxOState -> Lovelace
reserves UTxOState
st forall a. Num a => a -> a -> a
+ UTxO -> Lovelace
balance (UTxOState -> UTxO
utxo UTxOState
st)

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

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

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

utxoAndTxoutsMustBeDisjoint :: Property
utxoAndTxoutsMustBeDisjoint :: Property
utxoAndTxoutsMustBeDisjoint = TestLimit -> Property -> Property
withTests TestLimit
300 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Trace UTXOW
t <- 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)
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall {m :: * -> *}. MonadTest m => (UTxOState, TxBody) -> m ()
utxoAndTxoutsAreDisjoint forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Tx -> TxBody
body) forall a b. (a -> b) -> a -> b
$
      forall s. TraceOrder -> Trace s -> [(State s, Signal s)]
preStatesAndSignals TraceOrder
OldestFirst Trace UTXOW
t
  where
    utxoAndTxoutsAreDisjoint :: (UTxOState, TxBody) -> m ()
utxoAndTxoutsAreDisjoint (UTxOState {UTxO
utxo :: UTxO
utxo :: UTxOState -> UTxO
utxo}, TxBody
tx) =
      forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom UTxO
utxo forall a. Ord a => Set a -> Set a -> Set a
∩ forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom (TxBody -> UTxO
txouts TxBody
tx) forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a. Monoid a => a
mempty

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

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

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

      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
20 LabelName
"all txs have zero fee surplus" (Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n forall a. Eq a => a -> a -> Bool
== Int
0)
      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
20 LabelName
"avg. tx fee surplus (0,10]" (Int
0 forall a. Ord a => a -> a -> Bool
< Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n Bool -> Bool -> Bool
&& Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n forall a. Ord a => a -> a -> Bool
<= Int
10)
      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
20 LabelName
"avg. tx fee surplus (10,30]" (Int
10 forall a. Ord a => a -> a -> Bool
< Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n Bool -> Bool -> Bool
&& Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n forall a. Ord a => a -> a -> Bool
<= Int
30)
      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
1 LabelName
"avg. tx fee surplus (30,...)" (Int
30 forall a. Ord a => a -> a -> Bool
< Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n)

      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
20 LabelName
"avg. nr. of tx inputs (1,5]" (Double
1 forall a. Ord a => a -> a -> Bool
<= Double
avgInputs Bool -> Bool -> Bool
&& Double
avgInputs forall a. Ord a => a -> a -> Bool
<= Double
5)
      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
20 LabelName
"avg. nr. of tx inputs (5,10]" (Double
5 forall a. Ord a => a -> a -> Bool
< Double
avgInputs Bool -> Bool -> Bool
&& Double
avgInputs forall a. Ord a => a -> a -> Bool
<= Double
10)

      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
20 LabelName
"avg. nr. of tx outputs (1,5]" (Double
1 forall a. Ord a => a -> a -> Bool
<= Double
avgOutputs Bool -> Bool -> Bool
&& Double
avgOutputs forall a. Ord a => a -> a -> Bool
<= Double
5)
      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
20 LabelName
"avg. nr. of tx outputs (5,10]" (Double
5 forall a. Ord a => a -> a -> Bool
< Double
avgOutputs Bool -> Bool -> Bool
&& Double
avgOutputs forall a. Ord a => a -> a -> Bool
<= Double
10)

      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover CoverPercentage
80 LabelName
"starting UTxO has no future inputs" (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== forall a. Set a
empty) (Trace UTXOW -> [Set TxIn]
futureInputs Trace UTXOW
tr))
  where
    avgFeeSurplus :: Trace UTXOW -> Integer -> Int
    avgFeeSurplus :: Trace UTXOW -> Integer -> Int
avgFeeSurplus Trace UTXOW
tr Integer
n =
      forall s. TraceOrder -> Trace s -> [(State s, Signal s)]
preStatesAndSignals TraceOrder
OldestFirst Trace UTXOW
tr
        forall a b. a -> (a -> b) -> b
& forall a b. (a -> b) -> [a] -> [b]
map ((Tx -> Lovelace) -> (UTxOState, Tx) -> Integer
txFeeSurplus (PParams -> Tx -> Lovelace
pcMinFee PParams
pps_))
        forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        forall a b. a -> (a -> b) -> b
& (forall a. Integral a => a -> a -> a
`div` Integer
n)
        forall a b. a -> (a -> b) -> b
& forall a b. (Integral a, Num b) => a -> b
fromIntegral
      where
        pps_ :: PParams
pps_ = UTxOEnv -> PParams
pps (Trace UTXOW
tr forall s a. s -> Getting a s a -> a
^. forall s. Lens' (Trace s) (Environment s)
traceEnv)
    txFeeSurplus :: (Tx -> Lovelace) -> (UTxOState, Tx) -> Integer
    txFeeSurplus :: (Tx -> Lovelace) -> (UTxOState, Tx) -> Integer
txFeeSurplus Tx -> Lovelace
txMinFee (UTxOState
st, Tx
txw) =
      Integer
fee 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 forall a b. (a -> b) -> a -> b
$ UTxO -> Lovelace
balance (TxBody -> [TxIn]
txins TxBody
tx_ forall m (f :: * -> *).
(Relation m, Ord (Domain m), Foldable f) =>
f (Domain m) -> m -> m
◁ UTxO
utxo_) forall a. Num a => a -> a -> a
- UTxO -> Lovelace
balance (TxBody -> UTxO
txouts TxBody
tx_)
        minFee :: Integer
minFee = Lovelace -> Integer
unLovelace 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} = forall s. Trace s -> State s
_traceInitState Trace UTXOW
tr
          txs :: [TxBody]
txs = Tx -> TxBody
body forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
tr
       in (\TxBody
ti -> forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom (TxBody -> UTxO
txouts TxBody
ti) forall a. Ord a => Set a -> Set a -> Set a
∩ forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom UTxO
utxo0) 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 forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxBody]
txs of
    Int
0 -> (Double
0, Double
0)
    Int
n ->
      ( Double
nrInputs forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      , Double
nrOutputs forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      )
  where
    nrInputs :: Double
nrInputs = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody -> [TxIn]
inputs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxBody]
txs)
    nrOutputs :: Double
nrOutputs = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody -> [TxOut]
outputs 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let (Word64
tl, Word64
step) = (Word64
100, Word64
10)
  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
tl)
  forall s. Trace s -> Word64 -> Word64 -> PropertyT IO ()
classifyTraceLength Trace UTXOW
tr Word64
tl Word64
step

  let pparams :: PParams
pparams = UTxOEnv -> PParams
pps (Trace UTXOW
tr forall s a. s -> Getting a s a -> a
^. forall s. Lens' (Trace s) (Environment s)
traceEnv)
      -- Transaction with one input, one output and no witnesses
      unitTx :: Tx
unitTx = TxBody -> [Wit] -> Tx
Tx ([TxIn] -> [TxOut] -> TxBody
TxBody [TxId -> Natural -> TxIn
TxIn forall a. HasCallStack => a
undefined Natural
0] [Addr -> Lovelace -> TxOut
TxOut forall a. HasCallStack => a
undefined Lovelace
100]) []
      unitTxFee :: Lovelace
unitTxFee = PParams -> Tx -> Lovelace
pcMinFee PParams
pparams Tx
unitTx
  forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"Unit transaction cost == 0" forall a b. (a -> b) -> a -> b
$ Lovelace
unitTxFee forall a. Eq a => a -> a -> Bool
== Lovelace
0
  forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"Unit transaction cost == 1" forall a b. (a -> b) -> a -> b
$ Lovelace
unitTxFee forall a. Eq a => a -> a -> Bool
== Lovelace
1
  forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"Unit transaction cost [2, 5)" forall a b. (a -> b) -> a -> b
$ Lovelace
2 forall a. Ord a => a -> a -> Bool
<= Lovelace
unitTxFee Bool -> Bool -> Bool
&& Lovelace
unitTxFee forall a. Ord a => a -> a -> Bool
< Lovelace
5
  forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"Unit transaction cost [5, 10)" forall a b. (a -> b) -> a -> b
$ Lovelace
5 forall a. Ord a => a -> a -> Bool
<= Lovelace
unitTxFee Bool -> Bool -> Bool
&& Lovelace
unitTxFee forall a. Ord a => a -> a -> Bool
< Lovelace
10
  forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"Unit transaction cost [10, 25)" forall a b. (a -> b) -> a -> b
$ Lovelace
10 forall a. Ord a => a -> a -> Bool
<= Lovelace
unitTxFee Bool -> Bool -> Bool
&& Lovelace
unitTxFee forall a. Ord a => a -> a -> Bool
< Lovelace
25
  forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"Unit transaction cost [25, 100)" forall a b. (a -> b) -> a -> b
$ Lovelace
25 forall a. Ord a => a -> a -> Bool
<= Lovelace
unitTxFee Bool -> Bool -> Bool
&& Lovelace
unitTxFee forall a. Ord a => a -> a -> Bool
< Lovelace
100
  forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"Unit transaction cost >= 100" forall a b. (a -> b) -> a -> b
$ Lovelace
100 forall a. Ord a => a -> a -> Bool
<= Lovelace
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 :: Int
actualTl = forall s. Trace s -> Int
traceLength Trace UTXOW
tr
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
0 forall a. Ord a => a -> a -> Bool
< Int
actualTl) forall a b. (a -> b) -> a -> b
$ do
    let txs :: [TxBody]
txs = Tx -> TxBody
body forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace UTXOW
tr
        (Double
avgInputs, Double
avgOutputs) = [TxBody] -> (Double, Double)
avgInputsOutputs [TxBody]
txs

    -- Classify the average number of inputs
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. inputs == 0" forall a b. (a -> b) -> a -> b
$ (Double
0 :: Double) forall a. Eq a => a -> a -> Bool
== Double
avgInputs
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. inputs == 1" forall a b. (a -> b) -> a -> b
$ Double
1 forall a. Eq a => a -> a -> Bool
== Double
avgInputs
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. inputs [2, 5)" forall a b. (a -> b) -> a -> b
$ Double
2 forall a. Ord a => a -> a -> Bool
<= Double
avgInputs Bool -> Bool -> Bool
&& Double
avgInputs forall a. Ord a => a -> a -> Bool
< Double
5
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. inputs [5, 10)" forall a b. (a -> b) -> a -> b
$ Double
5 forall a. Ord a => a -> a -> Bool
<= Double
avgInputs Bool -> Bool -> Bool
&& Double
avgInputs forall a. Ord a => a -> a -> Bool
< Double
10
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. inputs [10, 25)" forall a b. (a -> b) -> a -> b
$ Double
10 forall a. Ord a => a -> a -> Bool
<= Double
avgInputs Bool -> Bool -> Bool
&& Double
avgInputs forall a. Ord a => a -> a -> Bool
< Double
25
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. inputs [25, 100)" forall a b. (a -> b) -> a -> b
$ Double
25 forall a. Ord a => a -> a -> Bool
<= Double
avgInputs Bool -> Bool -> Bool
&& Double
avgInputs forall a. Ord a => a -> a -> Bool
< Double
100
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
">= 100" forall a b. (a -> b) -> a -> b
$ Double
100 forall a. Ord a => a -> a -> Bool
<= Double
avgInputs
    -- Classify the average number of outputs
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. outputs == 0" forall a b. (a -> b) -> a -> b
$ (Double
0 :: Double) forall a. Eq a => a -> a -> Bool
== Double
avgOutputs
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. outputs == 1" forall a b. (a -> b) -> a -> b
$ Double
1 forall a. Eq a => a -> a -> Bool
== Double
avgOutputs
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. outputs [2, 5)" forall a b. (a -> b) -> a -> b
$ Double
2 forall a. Ord a => a -> a -> Bool
<= Double
avgOutputs Bool -> Bool -> Bool
&& Double
avgOutputs forall a. Ord a => a -> a -> Bool
< Double
5
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. outputs [5, 10)" forall a b. (a -> b) -> a -> b
$ Double
5 forall a. Ord a => a -> a -> Bool
<= Double
avgOutputs Bool -> Bool -> Bool
&& Double
avgOutputs forall a. Ord a => a -> a -> Bool
< Double
10
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. outputs [10, 25)" forall a b. (a -> b) -> a -> b
$ Double
10 forall a. Ord a => a -> a -> Bool
<= Double
avgOutputs Bool -> Bool -> Bool
&& Double
avgOutputs forall a. Ord a => a -> a -> Bool
< Double
25
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
"avg nr. outputs [25, 100)" forall a b. (a -> b) -> a -> b
$ Double
25 forall a. Ord a => a -> a -> Bool
<= Double
avgOutputs Bool -> Bool -> Bool
&& Double
avgOutputs forall a. Ord a => a -> a -> Bool
< Double
100
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
classify LabelName
">= 100" forall a b. (a -> b) -> a -> b
$ Double
100 forall a. Ord a => a -> a -> Bool
<= Double
avgOutputs
  forall (m :: * -> *). MonadTest m => m ()
success