{-# 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 = forall i.
(Integral i, Show i, HasCallStack) =>
Language -> [i] -> CostModel
mkCostModel' Language
lang forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [i]
params of
    Left CostModelApplyError
err ->
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
        [Char]
"CostModel parameters are not well-formed for "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Language
lang
          forall a. [a] -> [a] -> [a]
++ [Char]
": "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show CostModelApplyError
err
          forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
          forall a. [a] -> [a] -> [a]
++ 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 =
  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a -> b) -> a -> b
$ \Language
lang -> Map Language CostModel -> CostModels
mkCostModels (forall k a. k -> a -> Map k a
Map.singleton Language
lang (HasCallStack => Language -> CostModel
zeroTestingCostModel Language
lang))

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

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

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

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

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

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

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

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

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

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

alwaysSucceedsPlutus :: Natural -> Plutus l
alwaysSucceedsPlutus :: forall (l :: Language). Natural -> Plutus l
alwaysSucceedsPlutus Natural
n = 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 = 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 =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) (forall (l :: Language). PlutusBinary -> Plutus l
Plutus forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> PlutusBinary
PlutusBinary) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromCBOR a => Text -> Either DecoderError a
decodeFullFromHexText