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

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

import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  NonNegativeInterval,
  ProtVer (..),
  UnitInterval,
 )
import Cardano.Ledger.Binary.Version (Version)
import Cardano.Ledger.Coin (Coin, CompactForm)
import Cardano.Ledger.Plutus
import Data.Map.Strict (Map)
import Data.Word
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Plutus.ToPlutusData (roundTripPlutusDataSpec)

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
      CostModels
cms1 <- Map Word8 [Int64] -> IO CostModels
forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient Map Word8 [Int64]
cms1Flat
      CostModels
cms2 <- Map Word8 [Int64] -> IO CostModels
forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient Map Word8 [Int64]
cms2Flat
      CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
cms1 Map Word8 [Int64] -> Map Word8 [Int64] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Map Word8 [Int64]
cms1Flat
      CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
cms2 Map Word8 [Int64] -> Map Word8 [Int64] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Map Word8 [Int64]
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
  ExUnits
e <- Gen ExUnits
forall a. Arbitrary a => Gen a
arbitrary
  let result :: Maybe ExUnits
result = ExBudget -> Maybe ExUnits
exBudgetToExUnits (ExBudget -> Maybe ExUnits) -> ExBudget -> Maybe ExUnits
forall a b. (a -> b) -> a -> b
$ ExUnits -> ExBudget
transExUnits ExUnits
e
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      ( String
"Before: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ExUnits -> String
forall a. Show a => a -> String
show ExUnits
e
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n After: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe ExUnits -> String
forall a. Show a => a -> String
show Maybe ExUnits
result
      )
    (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Maybe ExUnits
result Maybe ExUnits -> Maybe ExUnits -> Bool
forall a. Eq a => a -> a -> Bool
== ExUnits -> Maybe ExUnits
forall a. a -> Maybe a
Just ExUnits
e

-- Plutus ExBudget should remain intact when translating to and from the ExUnits type
exBudgetToExUnitsRoundTrip :: Gen Property
exBudgetToExUnitsRoundTrip :: Gen Property
exBudgetToExUnitsRoundTrip = do
  ExBudget
e <- Gen ExBudget
forall a. Arbitrary a => Gen a
arbitrary
  let result :: Maybe ExBudget
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
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      ( String
"Before: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ExBudget -> String
forall a. Show a => a -> String
show ExBudget
e
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n After: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe ExBudget -> String
forall a. Show a => a -> String
show Maybe ExBudget
result
      )
    (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Maybe ExBudget
result Maybe ExBudget -> Maybe ExBudget -> Bool
forall a. Eq a => a -> a -> Bool
== ExBudget -> Maybe ExBudget
forall a. a -> Maybe a
Just ExBudget
e

dataSpec :: Spec
dataSpec :: Spec
dataSpec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RoundTrip ToPlutusData" (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 @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 @Word16
    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 @[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)
    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 @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 @Natural
    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 @EpochInterval
    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 @ProtVer
    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 @Integer