{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.PlutusSpec (spec) where

import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  NonNegativeInterval,
  NonZero,
  PositiveInterval,
  ProtVer (..),
  StrictMaybe,
  UnitInterval,
  getVersion,
  strictMaybeToMaybe,
  unboundRational,
 )
import Cardano.Ledger.Binary.Version (Version)
import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus
import Cardano.Slotting.Slot (SlotInterval (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word
import Numeric.Natural (Natural)
import qualified PlutusLedgerApi.V4 as PV4
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Plutus.ToPlutusData (roundTripPlutusDataSpec, sameAsToBuiltinDataSpec)

spec :: Spec
spec :: Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Plutus" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Spec
costModelsSpec
    Spec
exUnitsSpec
    Spec
dataSpec

costModelsSpec :: Spec
costModelsSpec :: Spec
costModelsSpec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CostModels" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> (CostModels -> Map Word8 [Int64] -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"flattenCostModels . mkCostModelsLenient" ((CostModels -> Map Word8 [Int64] -> IO ()) -> Spec)
-> (CostModels -> Map Word8 [Int64] -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \CostModels
valid Map Word8 [Int64]
unknown -> do
      let cms1Flat :: Map Word8 [Int64]
cms1Flat = CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
valid Map Word8 [Int64] -> Map Word8 [Int64] -> Map Word8 [Int64]
forall a. Semigroup a => a -> a -> a
<> Map Word8 [Int64]
unknown
          cms2Flat :: Map Word8 [Int64]
cms2Flat = Map Word8 [Int64]
unknown Map Word8 [Int64] -> Map Word8 [Int64] -> Map Word8 [Int64]
forall a. Semigroup a => a -> a -> a
<> CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
valid
      cms1 <- Map Word8 [Int64] -> IO CostModels
forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient Map Word8 [Int64]
cms1Flat
      cms2 <- mkCostModelsLenient cms2Flat
      flattenCostModels cms1 `shouldBe` cms1Flat
      flattenCostModels cms2 `shouldBe` cms2Flat

exUnitsSpec :: Spec
exUnitsSpec :: Spec
exUnitsSpec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ExUnits" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Gen Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Round-trip to ExBudget" Gen Property
exUnitsToExBudgetRoundTrip
    String -> Gen Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Round-trip from ExBudget" Gen Property
exBudgetToExUnitsRoundTrip

-- ExUnits should remain intact when translating to and from the Plutus ExBudget type
exUnitsToExBudgetRoundTrip :: Gen Property
exUnitsToExBudgetRoundTrip :: Gen Property
exUnitsToExBudgetRoundTrip = do
  e <- Gen ExUnits
forall a. Arbitrary a => Gen a
arbitrary
  let result = ExBudget -> Maybe ExUnits
exBudgetToExUnits (ExBudget -> Maybe ExUnits) -> ExBudget -> Maybe ExUnits
forall a b. (a -> b) -> a -> b
$ ExUnits -> ExBudget
transExUnits ExUnits
e
  pure
    $ counterexample
      ( "Before: "
          <> show e
          <> "\n After: "
          <> show result
      )
    $ result == Just e

-- Plutus ExBudget should remain intact when translating to and from the ExUnits type
exBudgetToExUnitsRoundTrip :: Gen Property
exBudgetToExUnitsRoundTrip :: Gen Property
exBudgetToExUnitsRoundTrip = do
  e <- Gen ExBudget
forall a. Arbitrary a => Gen a
arbitrary
  let result = ExUnits -> ExBudget
transExUnits (ExUnits -> ExBudget) -> Maybe ExUnits -> Maybe ExBudget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExBudget -> Maybe ExUnits
exBudgetToExUnits ExBudget
e
  pure
    $ counterexample
      ( "Before: "
          <> show e
          <> "\n After: "
          <> show result
      )
    $ result == Just e

dataSpec :: Spec
dataSpec :: Spec
dataSpec = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ToPlutusData" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RoundTrip" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Version
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @ProtVer
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Rational
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @UnitInterval
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @NonNegativeInterval
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @PositiveInterval
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @CostModels
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @ExUnits
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Prices
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Coin
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @(CompactForm Coin)
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @CoinPerByte
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @MaxPledgeLeverage
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Word32
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Word16
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Word8
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @EpochInterval
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @SlotInterval
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Natural
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Integer
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @Word
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @(NonZero Integer)
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @[Word]
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @[Word8]
    forall x.
(HasCallStack, Typeable x, Show x, Eq x, Arbitrary x,
 ToPlutusData x) =>
Spec
roundTripPlutusDataSpec @(Map Word Version)
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Same as ToData" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PlutusV4" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @Integer Integer -> Integer
forall a. a -> a
id
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @Word8 Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @Word16 Word16 -> Integer
forall a. Integral a => a -> Integer
toInteger
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @Word32 Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @Natural Natural -> Integer
forall a. Integral a => a -> Integer
toInteger
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @Rational Rational -> Rational
PV4.fromHaskellRatio
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @UnitInterval (Rational -> Rational
PV4.fromHaskellRatio (Rational -> Rational)
-> (UnitInterval -> Rational) -> UnitInterval -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational)
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @NonNegativeInterval (Rational -> Rational
PV4.fromHaskellRatio (Rational -> Rational)
-> (NonNegativeInterval -> Rational)
-> NonNegativeInterval
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational)
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @PositiveInterval (Rational -> Rational
PV4.fromHaskellRatio (Rational -> Rational)
-> (PositiveInterval -> Rational) -> PositiveInterval -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositiveInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational)
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @MaxPledgeLeverage ((MaxPledgeLeverage -> Maybe Rational) -> Spec)
-> (MaxPledgeLeverage -> Maybe Rational) -> Spec
forall a b. (a -> b) -> a -> b
$
        (NonNegativeInterval -> Rational)
-> Maybe NonNegativeInterval -> Maybe Rational
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rational -> Rational
PV4.fromHaskellRatio (Rational -> Rational)
-> (NonNegativeInterval -> Rational)
-> NonNegativeInterval
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational)
          (Maybe NonNegativeInterval -> Maybe Rational)
-> (MaxPledgeLeverage -> Maybe NonNegativeInterval)
-> MaxPledgeLeverage
-> Maybe Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictMaybe NonNegativeInterval -> Maybe NonNegativeInterval
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe
          (StrictMaybe NonNegativeInterval -> Maybe NonNegativeInterval)
-> (MaxPledgeLeverage -> StrictMaybe NonNegativeInterval)
-> MaxPledgeLeverage
-> Maybe NonNegativeInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaxPledgeLeverage -> StrictMaybe NonNegativeInterval
unMaxPledgeLeverage
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @Coin (Integer -> Lovelace
PV4.Lovelace (Integer -> Lovelace) -> (Coin -> Integer) -> Coin -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin)
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @(CompactForm Coin) (Integer -> Lovelace
PV4.Lovelace (Integer -> Lovelace)
-> (CompactForm Coin -> Integer) -> CompactForm Coin -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin (Coin -> Integer)
-> (CompactForm Coin -> Coin) -> CompactForm Coin -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact)
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @CoinPerByte (Integer -> Lovelace
PV4.Lovelace (Integer -> Lovelace)
-> (CoinPerByte -> Integer) -> CoinPerByte -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin (Coin -> Integer)
-> (CoinPerByte -> Coin) -> CoinPerByte -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (CoinPerByte -> CompactForm Coin) -> CoinPerByte -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoinPerByte -> CompactForm Coin
unCoinPerByte)
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @(StrictMaybe Integer) StrictMaybe Integer -> Maybe Integer
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @[Integer] [Integer] -> [Integer]
forall a. a -> a
id
      forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec @(Map Integer Integer) ([(Integer, Integer)] -> Map Integer Integer
forall k v. [(k, v)] -> Map k v
PV4.unsafeFromList ([(Integer, Integer)] -> Map Integer Integer)
-> (Map Integer Integer -> [(Integer, Integer)])
-> Map Integer Integer
-> Map Integer Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Integer Integer -> [(Integer, Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList)
      (ProtVer -> ProtocolVersion) -> Spec
forall x y.
(HasCallStack, Typeable x, Show x, Arbitrary x, ToPlutusData x,
 ToData y) =>
(x -> y) -> Spec
sameAsToBuiltinDataSpec ((ProtVer -> ProtocolVersion) -> Spec)
-> (ProtVer -> ProtocolVersion) -> Spec
forall a b. (a -> b) -> a -> b
$ \ProtVer {Version
pvMajor :: Version
pvMajor :: ProtVer -> Version
pvMajor, Word32
pvMinor :: Word32
pvMinor :: ProtVer -> Word32
pvMinor} -> Integer -> Integer -> ProtocolVersion
PV4.ProtocolVersion (Version -> Integer
forall i. Integral i => Version -> i
getVersion Version
pvMajor) (Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
pvMinor)