{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Plutus (
  PlutusArgs (..),
  ScriptTestContext (..),

  -- * Plutus
  alwaysSucceedsPlutus,
  alwaysFailsPlutus,
  decodeHexPlutus,

  -- * CostModel
  mkCostModelConst,
  zeroTestingCostModel,
  zeroTestingCostModelV1,
  zeroTestingCostModelV2,
  zeroTestingCostModelV3,
  testingCostModel,
  testingCostModelV1,
  testingCostModelV2,
  testingCostModelV3,
  testingEvaluationContext,

  -- * CostModels
  testingCostModels,
  zeroTestingCostModels,
) where

import Cardano.Ledger.Binary.Plain (decodeFullFromHexText)
import Cardano.Ledger.Plutus.CostModels (
  CostModel,
  CostModels,
  costModelParamsCount,
  getCostModelEvaluationContext,
  mkCostModel,
  mkCostModels,
 )
import Cardano.Ledger.Plutus.Language (
  Language (..),
  Plutus (..),
  PlutusBinary (..),
 )
import Data.Int (Int64)
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text (Text)
import GHC.Stack
import Numeric.Natural (Natural)
import qualified PlutusLedgerApi.Test.Examples as P (
  alwaysFailingNAryFunction,
  alwaysSucceedingNAryFunction,
 )
import qualified PlutusLedgerApi.Test.V1.EvaluationContext as PV1
import qualified PlutusLedgerApi.Test.V2.EvaluationContext as PV2
import qualified PlutusLedgerApi.Test.V3.EvaluationContext as PV3
import PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Plutus.ScriptTestContext (
  PlutusArgs (..),
  ScriptTestContext (..),
 )

-- | Construct a test cost model where all parameters are set to the same value
mkCostModelConst :: HasCallStack => Language -> Int64 -> CostModel
mkCostModelConst :: HasCallStack => Language -> Int64 -> CostModel
mkCostModelConst Language
lang = Language -> [Int64] -> CostModel
forall i.
(Integral i, Show i, HasCallStack) =>
Language -> [i] -> CostModel
mkCostModel' Language
lang ([Int64] -> CostModel) -> (Int64 -> [Int64]) -> Int64 -> CostModel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64 -> [Int64]
forall a. Int -> a -> [a]
replicate (Language -> Int
costModelParamsCount Language
lang)

mkCostModel' :: (Integral i, Show i, HasCallStack) => Language -> [i] -> CostModel
mkCostModel' :: forall i.
(Integral i, Show i, HasCallStack) =>
Language -> [i] -> CostModel
mkCostModel' Language
lang [i]
params =
  case Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
lang ([Int64] -> Either CostModelApplyError CostModel)
-> [Int64] -> Either CostModelApplyError CostModel
forall a b. (a -> b) -> a -> b
$ (i -> Int64) -> [i] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map i -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral [i]
params of
    Left CostModelApplyError
err ->
      [Char] -> CostModel
forall a. HasCallStack => [Char] -> a
error ([Char] -> CostModel) -> [Char] -> CostModel
forall a b. (a -> b) -> a -> b
$
        [Char]
"CostModel parameters are not well-formed for "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Language -> [Char]
forall a. Show a => a -> [Char]
show Language
lang
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CostModelApplyError -> [Char]
forall a. Show a => a -> [Char]
show CostModelApplyError
err
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [i] -> [Char]
forall a. Show a => a -> [Char]
show [i]
params
    Right CostModel
costModel -> CostModel
costModel

-- | Test CostModels for all available languages with zero values for all parameters
zeroTestingCostModels :: HasCallStack => [Language] -> CostModels
zeroTestingCostModels :: HasCallStack => [Language] -> CostModels
zeroTestingCostModels =
  (Language -> CostModels) -> [Language] -> CostModels
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Language -> CostModels) -> [Language] -> CostModels)
-> (Language -> CostModels) -> [Language] -> CostModels
forall a b. (a -> b) -> a -> b
$ \Language
lang -> Map Language CostModel -> CostModels
mkCostModels (Language -> CostModel -> Map Language CostModel
forall k a. k -> a -> Map k a
Map.singleton Language
lang (HasCallStack => Language -> CostModel
Language -> CostModel
zeroTestingCostModel Language
lang))

zeroTestingCostModel :: HasCallStack => Language -> CostModel
zeroTestingCostModel :: HasCallStack => Language -> CostModel
zeroTestingCostModel Language
lang = HasCallStack => Language -> Int64 -> CostModel
Language -> Int64 -> CostModel
mkCostModelConst Language
lang Int64
0

zeroTestingCostModelV1 :: HasCallStack => CostModel
zeroTestingCostModelV1 :: HasCallStack => CostModel
zeroTestingCostModelV1 = HasCallStack => Language -> CostModel
Language -> CostModel
zeroTestingCostModel Language
PlutusV1

zeroTestingCostModelV2 :: HasCallStack => CostModel
zeroTestingCostModelV2 :: HasCallStack => CostModel
zeroTestingCostModelV2 = HasCallStack => Language -> CostModel
Language -> CostModel
zeroTestingCostModel Language
PlutusV2

zeroTestingCostModelV3 :: HasCallStack => CostModel
zeroTestingCostModelV3 :: HasCallStack => CostModel
zeroTestingCostModelV3 = HasCallStack => Language -> CostModel
Language -> CostModel
zeroTestingCostModel Language
PlutusV3

-- | Test CostModels for all available languages
testingCostModels :: HasCallStack => [Language] -> CostModels
testingCostModels :: HasCallStack => [Language] -> CostModels
testingCostModels =
  (Language -> CostModels) -> [Language] -> CostModels
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Language -> CostModels) -> [Language] -> CostModels)
-> (Language -> CostModels) -> [Language] -> CostModels
forall a b. (a -> b) -> a -> b
$ \Language
lang -> Map Language CostModel -> CostModels
mkCostModels (Language -> CostModel -> Map Language CostModel
forall k a. k -> a -> Map k a
Map.singleton Language
lang (HasCallStack => Language -> CostModel
Language -> CostModel
testingCostModel Language
lang))

testingCostModel :: HasCallStack => Language -> CostModel
testingCostModel :: HasCallStack => Language -> CostModel
testingCostModel = \case
  Language
PlutusV1 -> CostModel
HasCallStack => CostModel
testingCostModelV1
  Language
PlutusV2 -> CostModel
HasCallStack => CostModel
testingCostModelV2
  Language
PlutusV3 -> CostModel
HasCallStack => CostModel
testingCostModelV3

testingCostModelV1 :: HasCallStack => CostModel
testingCostModelV1 :: HasCallStack => CostModel
testingCostModelV1 = Language -> [Int64] -> CostModel
forall i.
(Integral i, Show i, HasCallStack) =>
Language -> [i] -> CostModel
mkCostModel' Language
PlutusV1 ([Int64] -> CostModel) -> [Int64] -> CostModel
forall a b. (a -> b) -> a -> b
$ (ParamName, Int64) -> Int64
forall a b. (a, b) -> b
snd ((ParamName, Int64) -> Int64) -> [(ParamName, Int64)] -> [Int64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ParamName, Int64)]
PV1.costModelParamsForTesting

testingCostModelV2 :: HasCallStack => CostModel
testingCostModelV2 :: HasCallStack => CostModel
testingCostModelV2 = Language -> [Int64] -> CostModel
forall i.
(Integral i, Show i, HasCallStack) =>
Language -> [i] -> CostModel
mkCostModel' Language
PlutusV2 ([Int64] -> CostModel) -> [Int64] -> CostModel
forall a b. (a -> b) -> a -> b
$ (ParamName, Int64) -> Int64
forall a b. (a, b) -> b
snd ((ParamName, Int64) -> Int64) -> [(ParamName, Int64)] -> [Int64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ParamName, Int64)]
PV2.costModelParamsForTesting

testingCostModelV3 :: HasCallStack => CostModel
testingCostModelV3 :: HasCallStack => CostModel
testingCostModelV3 = Language -> [Int64] -> CostModel
forall i.
(Integral i, Show i, HasCallStack) =>
Language -> [i] -> CostModel
mkCostModel' Language
PlutusV3 ([Int64] -> CostModel) -> [Int64] -> CostModel
forall a b. (a -> b) -> a -> b
$ (ParamName, Int64) -> Int64
forall a b. (a, b) -> b
snd ((ParamName, Int64) -> Int64) -> [(ParamName, Int64)] -> [Int64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ParamName, Int64)]
HasCallStack => [(ParamName, Int64)]
PV3.costModelParamsForTesting

testingEvaluationContext :: Language -> PV1.EvaluationContext
testingEvaluationContext :: Language -> EvaluationContext
testingEvaluationContext = CostModel -> EvaluationContext
getCostModelEvaluationContext (CostModel -> EvaluationContext)
-> (Language -> CostModel) -> Language -> EvaluationContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Language -> CostModel
Language -> CostModel
testingCostModel

alwaysSucceedsPlutus :: Natural -> Plutus l
alwaysSucceedsPlutus :: forall (l :: Language). Natural -> Plutus l
alwaysSucceedsPlutus Natural
n = PlutusBinary -> Plutus l
forall (l :: Language). PlutusBinary -> Plutus l
Plutus (ShortByteString -> PlutusBinary
PlutusBinary (Natural -> ShortByteString
P.alwaysSucceedingNAryFunction Natural
n))

alwaysFailsPlutus :: Natural -> Plutus l
alwaysFailsPlutus :: forall (l :: Language). Natural -> Plutus l
alwaysFailsPlutus Natural
n = PlutusBinary -> Plutus l
forall (l :: Language). PlutusBinary -> Plutus l
Plutus (ShortByteString -> PlutusBinary
PlutusBinary (Natural -> ShortByteString
P.alwaysFailingNAryFunction Natural
n))

decodeHexPlutus :: HasCallStack => Text.Text -> Plutus l
decodeHexPlutus :: forall (l :: Language). HasCallStack => Text -> Plutus l
decodeHexPlutus =
  (DecoderError -> Plutus l)
-> (ShortByteString -> Plutus l)
-> Either DecoderError ShortByteString
-> Plutus l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Plutus l
forall a. HasCallStack => [Char] -> a
error ([Char] -> Plutus l)
-> (DecoderError -> [Char]) -> DecoderError -> Plutus l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> [Char]
forall a. Show a => a -> [Char]
show) (PlutusBinary -> Plutus l
forall (l :: Language). PlutusBinary -> Plutus l
Plutus (PlutusBinary -> Plutus l)
-> (ShortByteString -> PlutusBinary) -> ShortByteString -> Plutus l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> PlutusBinary
PlutusBinary) (Either DecoderError ShortByteString -> Plutus l)
-> (Text -> Either DecoderError ShortByteString)
-> Text
-> Plutus l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either DecoderError ShortByteString
forall a. FromCBOR a => Text -> Either DecoderError a
decodeFullFromHexText