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

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

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.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. String -> GenT Identity a
forall (m :: * -> *) a. MonadFail m => 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
  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
      { Alonzo.agCoinsPerUTxOWord = Ledger.CoinPerWord coinsPerUTxOWord
      , Alonzo.agCostModels = mempty
      , Alonzo.agPrices = prices'
      , Alonzo.agMaxTxExUnits = maxTxExUnits'
      , Alonzo.agMaxBlockExUnits = maxBlockExUnits'
      , Alonzo.agMaxValSize = maxValSize'
      , Alonzo.agCollateralPercentage = collateralPercentage'
      , Alonzo.agMaxCollateralInputs = maxCollateralInputs'
      }