{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Gen.Cardano.Api
  ( genMetadata
  , genAlonzoGenesis
  )
where

import Cardano.Api.Genesis (defaultV1CostModel)

import Cardano.Ledger.Alonzo.Core qualified as Ledger
import Cardano.Ledger.Alonzo.Genesis qualified as Alonzo
import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo
import Cardano.Ledger.Alonzo.Scripts qualified as L
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Coin qualified as Ledger
import Cardano.Ledger.Plutus.CostModels qualified as Plutus
import Cardano.Ledger.Plutus.Language qualified as Alonzo
import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..), ShelleyTxAuxData (..))

import Data.Map.Strict qualified as Map
import Data.Word (Word64)
import GHC.Exts (IsList (..))

import Test.Gen.Cardano.Api.Typed (genCostModel, genRational)

import Hedgehog (Gen, Range)
import Hedgehog.Gen qualified as Gen
import Hedgehog.Internal.Range qualified as Range

genMetadata :: Ledger.Era era => Gen (ShelleyTxAuxData era)
genMetadata :: forall era. Era era => Gen (ShelleyTxAuxData era)
genMetadata = do
  numberOfIndices <- Range Int -> GenT Identity Int
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
15)
  let indices = (Int -> Word64) -> [Int] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Word64) [Int
1 .. Int
numberOfIndices]
  mData <- Gen.list (Range.singleton numberOfIndices) genMetadatum
  return . ShelleyTxAuxData . fromList $ zip indices mData

genMetadatum :: Gen Metadatum
genMetadatum :: GenT Identity Metadatum
genMetadatum = do
  int <- Range Int -> GenT Identity Metadatum -> GenT Identity [Metadatum]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
5) (Integer -> Metadatum
I (Integer -> Metadatum)
-> GenT Identity Integer -> GenT Identity Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Integer -> GenT Identity Integer
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (Integer -> Integer -> Range Integer
forall a. Integral a => a -> a -> Range a
Range.linear Integer
1 Integer
100))
  bytes <- Gen.list (Range.linear 1 5) (B <$> Gen.bytes (Range.linear 1 20))
  str <- Gen.list (Range.linear 1 5) (S <$> Gen.text (Range.linear 1 20) Gen.alphaNum)
  let mDatumList = [Metadatum]
int [Metadatum] -> [Metadatum] -> [Metadatum]
forall a. [a] -> [a] -> [a]
++ [Metadatum]
bytes [Metadatum] -> [Metadatum] -> [Metadatum]
forall a. [a] -> [a] -> [a]
++ [Metadatum]
str

  singleMetadatum <- Gen.element mDatumList

  Gen.element
    [ List mDatumList
    , Map [(singleMetadatum, singleMetadatum)]
    , Map [(List mDatumList, singleMetadatum)]
    , Map [(singleMetadatum, List mDatumList)]
    ]

genCoin :: Range Integer -> Gen Ledger.Coin
genCoin :: Range Integer -> Gen Coin
genCoin Range Integer
r = do
  unCoin' <- Range Integer -> GenT Identity Integer
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral Range Integer
r
  return $ Ledger.Coin unCoin'

genPrice :: Gen Ledger.NonNegativeInterval
genPrice :: Gen NonNegativeInterval
genPrice = do
  unPrice <- Gen Rational
genRational
  case Ledger.boundRational unPrice of
    Maybe NonNegativeInterval
Nothing -> String -> Gen NonNegativeInterval
forall a. HasCallStack => String -> GenT Identity a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"genPrice: genRational should give us a bounded rational"
    Just NonNegativeInterval
p -> NonNegativeInterval -> Gen NonNegativeInterval
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonNegativeInterval
p

genPrices :: Gen Alonzo.Prices
genPrices :: Gen Prices
genPrices = do
  prMem' <- Gen NonNegativeInterval
genPrice
  prSteps' <- genPrice

  return
    Alonzo.Prices
      { Alonzo.prMem = prMem'
      , Alonzo.prSteps = prSteps'
      }

genExUnits :: Gen Alonzo.ExUnits
genExUnits :: Gen ExUnits
genExUnits = do
  exUnitsMem' <- Range Natural -> GenT Identity Natural
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (Natural -> Natural -> Range Natural
forall a. Integral a => a -> a -> Range a
Range.linear Natural
0 Natural
10)
  exUnitsSteps' <- Gen.integral (Range.linear 0 10)
  return
    Alonzo.ExUnits
      { Alonzo.exUnitsMem = exUnitsMem'
      , Alonzo.exUnitsSteps = exUnitsSteps'
      }

genCostModels :: Gen Alonzo.CostModels
genCostModels :: Gen CostModels
genCostModels = do
  alonzoCostModel <- GenT Identity CostModel
forall (m :: * -> *). MonadGen m => m CostModel
genCostModel
  Plutus.mkCostModels . conv <$> Gen.list (Range.linear 1 3) (return alonzoCostModel)
 where
  conv :: [Alonzo.CostModel] -> Map.Map Alonzo.Language Alonzo.CostModel
  conv :: [CostModel] -> Map Language CostModel
conv [] = Map Language CostModel
forall a. Monoid a => a
mempty
  conv (CostModel
c : [CostModel]
rest) = Language -> CostModel -> Map Language CostModel
forall k a. k -> a -> Map k a
Map.singleton (CostModel -> Language
Alonzo.getCostModelLanguage CostModel
c) CostModel
c Map Language CostModel
-> Map Language CostModel -> Map Language CostModel
forall a. Semigroup a => a -> a -> a
<> [CostModel] -> Map Language CostModel
conv [CostModel]
rest

genAlonzoGenesis :: Gen Alonzo.AlonzoGenesis
genAlonzoGenesis :: Gen AlonzoGenesis
genAlonzoGenesis = do
  coinsPerUTxOWord <- Range Integer -> Gen Coin
genCoin (Integer -> Integer -> Range Integer
forall a. Integral a => a -> a -> Range a
Range.linear Integer
0 Integer
5)
  -- TODO: Babbage: Figure out how to deal with the asymmetric cost model JSON
  costmdls' <- genCostModels
  v1CostModel <- case Map.lookup Alonzo.PlutusV1 $ L.costModelsValid costmdls' of
    Just CostModel
cm -> CostModel -> GenT Identity CostModel
forall a. a -> GenT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return CostModel
cm
    Maybe CostModel
Nothing -> CostModel -> GenT Identity CostModel
forall a. a -> GenT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return CostModel
defaultV1CostModel

  let v2OnwardsCostModels =
        [Map Language CostModel] -> Map Language CostModel
forall a. Monoid a => [a] -> a
mconcat ([Map Language CostModel] -> Map Language CostModel)
-> [Map Language CostModel] -> Map Language CostModel
forall a b. (a -> b) -> a -> b
$
          (Language -> Map Language CostModel)
-> [Language] -> [Map Language CostModel]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \Language
l -> case Language
l Language -> Map Language CostModel -> Maybe CostModel
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` CostModels -> Map Language CostModel
L.costModelsValid CostModels
costmdls' of
                Just CostModel
cm -> Language -> CostModel -> Map Language CostModel
forall k a. k -> a -> Map k a
Map.singleton Language
l CostModel
cm
                Maybe CostModel
Nothing -> Map Language CostModel
forall k a. Map k a
Map.empty
            )
            [Language
Alonzo.PlutusV2 .. Language
forall a. Bounded a => a
maxBound]
      extraConfig = AlonzoExtraConfig -> Maybe AlonzoExtraConfig
forall a. a -> Maybe a
Just (AlonzoExtraConfig -> Maybe AlonzoExtraConfig)
-> AlonzoExtraConfig -> Maybe AlonzoExtraConfig
forall a b. (a -> b) -> a -> b
$ Maybe CostModels -> AlonzoExtraConfig
Alonzo.AlonzoExtraConfig (Maybe CostModels -> AlonzoExtraConfig)
-> Maybe CostModels -> AlonzoExtraConfig
forall a b. (a -> b) -> a -> b
$ CostModels -> Maybe CostModels
forall a. a -> Maybe a
Just (CostModels -> Maybe CostModels) -> CostModels -> Maybe CostModels
forall a b. (a -> b) -> a -> b
$ Map Language CostModel -> CostModels
L.mkCostModels Map Language CostModel
v2OnwardsCostModels
  prices' <- genPrices
  maxTxExUnits' <- genExUnits
  maxBlockExUnits' <- genExUnits
  maxValSize' <- Gen.integral (Range.linear 0 10)
  collateralPercentage' <- Gen.integral (Range.linear 0 10)
  maxCollateralInputs' <- Gen.integral (Range.linear 0 10)

  return $
    Alonzo.AlonzoGenesis
      (Ledger.CoinPerWord coinsPerUTxOWord)
      v1CostModel
      prices'
      maxTxExUnits'
      maxBlockExUnits'
      maxValSize'
      collateralPercentage'
      maxCollateralInputs'
      extraConfig