{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Test.Cardano.Chain.UTxO.Compact (
  tests,
) where

import Cardano.Chain.UTxO (
  fromCompactTxId,
  fromCompactTxIn,
  fromCompactTxOut,
  toCompactTxId,
  toCompactTxIn,
  toCompactTxOut,
 )
import Cardano.HeapWords (HeapWords (..))
import Cardano.Prelude
import Hedgehog (MonadTest, assert, forAll, property, tripping)
import Test.Cardano.Chain.UTxO.Gen (genTxId, genTxIn, genTxOut)
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, concatTSGroups, eachOfTS, withTestsTS)

--------------------------------------------------------------------------------
-- Compact TxIn
--------------------------------------------------------------------------------

ts_roundTripCompactTxIn :: TSProperty
ts_roundTripCompactTxIn :: TSProperty
ts_roundTripCompactTxIn =
  TestLimit -> Gen TxIn -> (TxIn -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
1000 Gen TxIn
genTxIn ((TxIn -> CompactTxIn)
-> (CompactTxIn -> TxIn) -> TxIn -> PropertyT IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadTest m, Show a, Show b, Eq a) =>
(a -> b) -> (b -> a) -> a -> m ()
trippingCompact TxIn -> CompactTxIn
toCompactTxIn CompactTxIn -> TxIn
fromCompactTxIn)

ts_prop_heapWordsSavingsCompactTxIn :: TSProperty
ts_prop_heapWordsSavingsCompactTxIn :: TSProperty
ts_prop_heapWordsSavingsCompactTxIn = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000
  (Property -> TSProperty) -> Property -> TSProperty
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
    TxIn
txIn <- Gen TxIn -> PropertyT IO TxIn
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen TxIn
genTxIn
    let compactTxIn :: CompactTxIn
compactTxIn = TxIn -> CompactTxIn
toCompactTxIn TxIn
txIn
    Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert (Bool -> PropertyT IO ()) -> Bool -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ CompactTxIn -> Int
forall a. HeapWords a => a -> Int
heapWords CompactTxIn
compactTxIn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< TxIn -> Int
forall a. HeapWords a => a -> Int
heapWords TxIn
txIn

--------------------------------------------------------------------------------
-- Compact TxId
--------------------------------------------------------------------------------

ts_roundTripCompactTxId :: TSProperty
ts_roundTripCompactTxId :: TSProperty
ts_roundTripCompactTxId =
  TestLimit -> Gen TxId -> (TxId -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
1000 Gen TxId
genTxId ((TxId -> CompactTxId)
-> (CompactTxId -> TxId) -> TxId -> PropertyT IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadTest m, Show a, Show b, Eq a) =>
(a -> b) -> (b -> a) -> a -> m ()
trippingCompact TxId -> CompactTxId
toCompactTxId CompactTxId -> TxId
fromCompactTxId)

ts_prop_heapWordsSavingsCompactTxId :: TSProperty
ts_prop_heapWordsSavingsCompactTxId :: TSProperty
ts_prop_heapWordsSavingsCompactTxId = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000
  (Property -> TSProperty) -> Property -> TSProperty
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
    TxId
txId <- Gen TxId -> PropertyT IO TxId
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen TxId
genTxId
    let compactTxId :: CompactTxId
compactTxId = TxId -> CompactTxId
toCompactTxId TxId
txId
    Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert (Bool -> PropertyT IO ()) -> Bool -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ CompactTxId -> Int
forall a. HeapWords a => a -> Int
heapWords CompactTxId
compactTxId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< TxId -> Int
forall a. HeapWords a => a -> Int
heapWords TxId
txId

--------------------------------------------------------------------------------
-- Compact TxOut
--------------------------------------------------------------------------------

ts_roundTripCompactTxOut :: TSProperty
ts_roundTripCompactTxOut :: TSProperty
ts_roundTripCompactTxOut =
  TestLimit -> Gen TxOut -> (TxOut -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
1000 Gen TxOut
genTxOut ((TxOut -> CompactTxOut)
-> (CompactTxOut -> TxOut) -> TxOut -> PropertyT IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadTest m, Show a, Show b, Eq a) =>
(a -> b) -> (b -> a) -> a -> m ()
trippingCompact TxOut -> CompactTxOut
toCompactTxOut CompactTxOut -> TxOut
fromCompactTxOut)

ts_prop_heapWordsSavingsCompactTxOut :: TSProperty
ts_prop_heapWordsSavingsCompactTxOut :: TSProperty
ts_prop_heapWordsSavingsCompactTxOut = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000
  (Property -> TSProperty) -> Property -> TSProperty
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
    TxOut
txOut <- Gen TxOut -> PropertyT IO TxOut
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen TxOut
genTxOut
    let compactTxOut :: CompactTxOut
compactTxOut = TxOut -> CompactTxOut
toCompactTxOut TxOut
txOut
    Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert (Bool -> PropertyT IO ()) -> Bool -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ CompactTxOut -> Int
forall a. HeapWords a => a -> Int
heapWords CompactTxOut
compactTxOut Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< TxOut -> Int
forall a. HeapWords a => a -> Int
heapWords TxOut
txOut

-------------------------------------------------------------------------------
-- Tripping util
-------------------------------------------------------------------------------

trippingCompact ::
  (HasCallStack, MonadTest m, Show a, Show b, Eq a) =>
  (a -> b) ->
  (b -> a) ->
  a ->
  m ()
trippingCompact :: forall (m :: * -> *) a b.
(HasCallStack, MonadTest m, Show a, Show b, Eq a) =>
(a -> b) -> (b -> a) -> a -> m ()
trippingCompact a -> b
toCompact b -> a
fromCompact a
x =
  a -> (a -> b) -> (b -> Identity a) -> m ()
forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
tripping a
x a -> b
toCompact (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (b -> a) -> b -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
fromCompact)

-------------------------------------------------------------------------------
-- Main test export
-------------------------------------------------------------------------------

tests :: TSGroup
tests :: TSGroup
tests = [TSGroup] -> TSGroup
concatTSGroups [$$discoverPropArg, $$discoverRoundTripArg]