{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Export the EraGen instance for MaryEra, as well as some reusable functions for future Eras
module Test.Cardano.Ledger.MaryEraGen (
  genMint,
  maryGenesisValue,
  policyIndex,
  addTokens,
) where

import Cardano.Ledger.Allegra.Scripts (AllegraEraScript)
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Mary.TxBody (TxBody (MaryTxBody))
import Cardano.Ledger.Mary.Value (
  AssetName (..),
  MaryValue (..),
  MultiAsset,
  PolicyID (..),
  multiAssetFromList,
  policies,
 )
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.TxBody (Withdrawals)
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (ShelleyTxWits))
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.Val ((<+>))
import qualified Cardano.Ledger.Val as Val
import Cardano.Slotting.Slot (SlotNo)
import Control.Monad (replicateM)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Data.Sequence.Strict (StrictSeq (..), (<|), (><))
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import GHC.Exts (fromString)
import Lens.Micro
import Test.Cardano.Ledger.Allegra.Arbitrary ()
import Test.Cardano.Ledger.AllegraEraGen (
  genValidityInterval,
  quantifyTL,
  someLeaf,
  unQuantifyTL,
 )
import Test.Cardano.Ledger.EraBuffet (MaryEra)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv (..), genInteger)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), MinGenTxout (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (
  ScriptClass (..),
  exponential,
 )
import Test.Cardano.Ledger.Shelley.Generator.Update (genPParams, genShelleyPParamsUpdate)
import Test.Cardano.Ledger.Shelley.Utils (Split (..))
import Test.QuickCheck (Gen, arbitrary, frequency)
import qualified Test.QuickCheck as QC

{------------------------------------------------------------------------------
 EraGen instance for MaryEra - This instance makes it possible to run the
 Shelley property tests for MaryEra
------------------------------------------------------------------------------}

instance ScriptClass MaryEra where
  isKey :: Proxy MaryEra -> Script MaryEra -> Maybe (KeyHash Witness)
isKey Proxy MaryEra
_ (RequireSignature KeyHash Witness
hk) = KeyHash Witness -> Maybe (KeyHash Witness)
forall a. a -> Maybe a
Just KeyHash Witness
hk
  isKey Proxy MaryEra
_ Script MaryEra
_ = Maybe (KeyHash Witness)
forall a. Maybe a
Nothing
  basescript :: Proxy MaryEra -> KeyHash Witness -> Script MaryEra
basescript Proxy MaryEra
_proxy = forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyHash Witness -> NativeScript era
someLeaf @MaryEra
  quantify :: Proxy MaryEra -> Script MaryEra -> Quantifier (Script MaryEra)
quantify Proxy MaryEra
_ = NativeScript MaryEra -> Quantifier (NativeScript MaryEra)
Script MaryEra -> Quantifier (Script MaryEra)
forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL
  unQuantify :: Proxy MaryEra -> Quantifier (Script MaryEra) -> Script MaryEra
unQuantify Proxy MaryEra
_ = Quantifier (NativeScript MaryEra) -> NativeScript MaryEra
Quantifier (Script MaryEra) -> Script MaryEra
forall era.
AllegraEraScript era =>
Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL

instance EraGen MaryEra where
  genGenesisValue :: forall c. GenEnv c MaryEra -> Gen (Value MaryEra)
genGenesisValue = GenEnv c MaryEra -> Gen (Value MaryEra)
GenEnv c MaryEra -> Gen MaryValue
forall c era. GenEnv c era -> Gen MaryValue
maryGenesisValue
  genEraTxBody :: forall c.
GenEnv c MaryEra
-> UTxO MaryEra
-> PParams MaryEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx MaryEra, [Script MaryEra])
genEraTxBody GenEnv c MaryEra
_ge UTxO MaryEra
_utxo = PParams MaryEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx MaryEra, [Script MaryEra])
PParams MaryEra
-> SlotNo
-> Set TxIn
-> StrictSeq (ShelleyTxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx MaryEra, [NativeScript MaryEra])
genTxBody
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData MaryEra))
genEraAuxiliaryData = Constants -> Gen (StrictMaybe (TxAuxData MaryEra))
genAuxiliaryData
  updateEraTxBody :: UTxO MaryEra
-> PParams MaryEra
-> TxWits MaryEra
-> TxBody TopTx MaryEra
-> Coin
-> Set TxIn
-> TxOut MaryEra
-> TxBody TopTx MaryEra
updateEraTxBody UTxO MaryEra
_utxo PParams MaryEra
_pp TxWits MaryEra
_wits TxBody TopTx MaryEra
txBody Coin
fee Set TxIn
ins TxOut MaryEra
out =
    TxBody TopTx MaryEra
txBody
      TxBody TopTx MaryEra
-> (TxBody TopTx MaryEra -> TxBody TopTx MaryEra)
-> TxBody TopTx MaryEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx MaryEra -> Identity (TxBody TopTx MaryEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l MaryEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx MaryEra -> Identity (TxBody TopTx MaryEra))
-> Set TxIn -> TxBody TopTx MaryEra -> TxBody TopTx MaryEra
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set TxIn
ins
      TxBody TopTx MaryEra
-> (TxBody TopTx MaryEra -> TxBody TopTx MaryEra)
-> TxBody TopTx MaryEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut MaryEra) -> Identity (StrictSeq (TxOut MaryEra)))
-> TxBody TopTx MaryEra -> Identity (TxBody TopTx MaryEra)
(StrictSeq (ShelleyTxOut MaryEra)
 -> Identity (StrictSeq (ShelleyTxOut MaryEra)))
-> TxBody TopTx MaryEra -> Identity (TxBody TopTx MaryEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l MaryEra) (StrictSeq (TxOut MaryEra))
outputsTxBodyL ((StrictSeq (ShelleyTxOut MaryEra)
  -> Identity (StrictSeq (ShelleyTxOut MaryEra)))
 -> TxBody TopTx MaryEra -> Identity (TxBody TopTx MaryEra))
-> (StrictSeq (ShelleyTxOut MaryEra)
    -> StrictSeq (ShelleyTxOut MaryEra))
-> TxBody TopTx MaryEra
-> TxBody TopTx MaryEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (TxOut MaryEra)
-> TxOut MaryEra -> StrictSeq (TxOut MaryEra)
forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut MaryEra
out)
      TxBody TopTx MaryEra
-> (TxBody TopTx MaryEra -> TxBody TopTx MaryEra)
-> TxBody TopTx MaryEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx MaryEra -> Identity (TxBody TopTx MaryEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx MaryEra) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx MaryEra -> Identity (TxBody TopTx MaryEra))
-> Coin -> TxBody TopTx MaryEra -> TxBody TopTx MaryEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
  genEraPParamsUpdate :: Constants -> PParams MaryEra -> Gen (PParamsUpdate MaryEra)
genEraPParamsUpdate = Constants -> PParams MaryEra -> Gen (PParamsUpdate MaryEra)
forall era.
(AtMostEra "Mary" era, AtMostEra "Alonzo" era,
 AtMostEra "Babbage" era, EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate
  genEraPParams :: Constants -> Gen (PParams MaryEra)
genEraPParams = Constants -> Gen (PParams MaryEra)
forall era.
(EraPParams era, AtMostEra "Mary" era, AtMostEra "Alonzo" era) =>
Constants -> Gen (PParams era)
genPParams
  genEraTxWits :: (UTxO MaryEra, TxBody TopTx MaryEra, ScriptInfo MaryEra)
-> Set (WitVKey Witness)
-> Map ScriptHash (Script MaryEra)
-> TxWits MaryEra
genEraTxWits (UTxO MaryEra, TxBody TopTx MaryEra, ScriptInfo MaryEra)
_scriptinfo Set (WitVKey Witness)
setWitVKey Map ScriptHash (Script MaryEra)
mapScriptWit = Set (WitVKey Witness)
-> Map ScriptHash (Script MaryEra)
-> Set BootstrapWitness
-> ShelleyTxWits MaryEra
forall era.
EraScript era =>
Set (WitVKey Witness)
-> Map ScriptHash (Script era)
-> Set BootstrapWitness
-> ShelleyTxWits era
ShelleyTxWits Set (WitVKey Witness)
setWitVKey Map ScriptHash (Script MaryEra)
mapScriptWit Set BootstrapWitness
forall a. Monoid a => a
mempty

genAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData MaryEra))
genAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData MaryEra))
genAuxiliaryData Constants {Int
frequencyTxWithMetadata :: Int
frequencyTxWithMetadata :: Constants -> Int
frequencyTxWithMetadata} =
  [(Int, Gen (StrictMaybe (AllegraTxAuxData MaryEra)))]
-> Gen (StrictMaybe (AllegraTxAuxData MaryEra))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
frequencyTxWithMetadata, AllegraTxAuxData MaryEra -> StrictMaybe (AllegraTxAuxData MaryEra)
forall a. a -> StrictMaybe a
SJust (AllegraTxAuxData MaryEra
 -> StrictMaybe (AllegraTxAuxData MaryEra))
-> Gen (AllegraTxAuxData MaryEra)
-> Gen (StrictMaybe (AllegraTxAuxData MaryEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (AllegraTxAuxData MaryEra)
forall a. Arbitrary a => Gen a
arbitrary)
    , (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
frequencyTxWithMetadata, StrictMaybe (AllegraTxAuxData MaryEra)
-> Gen (StrictMaybe (AllegraTxAuxData MaryEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (AllegraTxAuxData MaryEra)
forall a. StrictMaybe a
SNothing)
    ]

-- | Carefully crafted to apply in any Era where Value is MaryValue
maryGenesisValue :: GenEnv c era -> Gen MaryValue
maryGenesisValue :: forall c era. GenEnv c era -> Gen MaryValue
maryGenesisValue (GenEnv KeySpace c era
_ ScriptSpace era
_ Constants {Integer
minGenesisOutputVal :: Integer
minGenesisOutputVal :: Constants -> Integer
minGenesisOutputVal, Integer
maxGenesisOutputVal :: Integer
maxGenesisOutputVal :: Constants -> Integer
maxGenesisOutputVal}) =
  Coin -> MaryValue
forall t s. Inject t s => t -> s
Val.inject (Coin -> MaryValue) -> (Integer -> Coin) -> Integer -> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin (Integer -> MaryValue) -> Gen Integer -> Gen MaryValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Integer
exponential Integer
minGenesisOutputVal Integer
maxGenesisOutputVal

--------------------------------------------------------
-- Permissionless Tokens                              --
--                                                    --
-- We introduce three token bundles, each which has a --
-- permissionless minting policy and each which has a --
-- different minting behavior (use of asset names).   --
--------------------------------------------------------

-- | An infinite indexed collection of trivial policies.
--  They are trivial in the sense that they require no
--  signature and can be submitted at any time.
trivialPolicy :: AllegraEraScript era => Int -> NativeScript era
trivialPolicy :: forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy Int
i
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [])
  | Bool
otherwise = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Int -> NativeScript era
forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)])

coloredCoinMinMint :: Integer
coloredCoinMinMint :: Integer
coloredCoinMinMint = Integer
1000

coloredCoinMaxMint :: Integer
coloredCoinMaxMint :: Integer
coloredCoinMaxMint = Integer
1000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000

--------------------------------------------------------
-- Red Coins                                          --
--                                                    --
-- These tokens are always minted with the same asset --
-- name, "red".                                       --
--------------------------------------------------------

redCoins :: AllegraEraScript era => NativeScript era
redCoins :: forall era. AllegraEraScript era => NativeScript era
redCoins = Int -> NativeScript era
forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy Int
0

redCoinId :: PolicyID
redCoinId :: PolicyID
redCoinId = ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID) -> ScriptHash -> PolicyID
forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @MaryEra NativeScript MaryEra
Script MaryEra
forall era. AllegraEraScript era => NativeScript era
redCoins

red :: AssetName
red :: AssetName
red = ShortByteString -> AssetName
AssetName ShortByteString
"red"

genRed :: Gen MultiAsset
genRed :: Gen MultiAsset
genRed = do
  n <- Integer -> Integer -> Gen Integer
genInteger Integer
coloredCoinMinMint Integer
coloredCoinMaxMint
  pure $ multiAssetFromList [(redCoinId, red, n)]

--------------------------------------------------------
-- Blue Coins                                         --
--                                                    --
-- These tokens are (nearly) always minted with a new --
-- asset name.
--------------------------------------------------------

blueCoins :: AllegraEraScript era => NativeScript era
blueCoins :: forall era. AllegraEraScript era => NativeScript era
blueCoins = Int -> NativeScript era
forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy Int
1

blueCoinId :: PolicyID
blueCoinId :: PolicyID
blueCoinId = ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID) -> ScriptHash -> PolicyID
forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @MaryEra NativeScript MaryEra
Script MaryEra
forall era. AllegraEraScript era => NativeScript era
blueCoins

maxBlueMint :: Int
maxBlueMint :: Int
maxBlueMint = Int
5

-- TODO these blue coins are actually problematic since our
-- current coin selection algorithm does not prevent creating
-- a multi-asset that is too large.

genBlue :: Gen MultiAsset
genBlue :: Gen MultiAsset
genBlue = do
  as <- Int -> Gen [(AssetName, Integer)] -> Gen [(AssetName, Integer)]
forall a. HasCallStack => Int -> Gen a -> Gen a
QC.resize Int
maxBlueMint (Gen [(AssetName, Integer)] -> Gen [(AssetName, Integer)])
-> Gen [(AssetName, Integer)] -> Gen [(AssetName, Integer)]
forall a b. (a -> b) -> a -> b
$ Gen (AssetName, Integer) -> Gen [(AssetName, Integer)]
forall a. Gen a -> Gen [a]
QC.listOf Gen (AssetName, Integer)
genSingleBlue
  -- the transaction size gets too big if we mint too many assets
  pure $ multiAssetFromList (map (\(AssetName
asset, Integer
count) -> (PolicyID
blueCoinId, AssetName
asset, Integer
count)) as)
  where
    genSingleBlue :: Gen (AssetName, Integer)
genSingleBlue = do
      n <- Integer -> Integer -> Gen Integer
genInteger Integer
coloredCoinMinMint Integer
coloredCoinMaxMint
      a <- arbitrary
      pure (AssetName a, n)

--------------------------------------------------------
-- Yellow Coins                                       --
--                                                    --
-- These tokens are minted with a small variety of    --
-- asset names.                                       --
--------------------------------------------------------

yellowCoins :: AllegraEraScript era => NativeScript era
yellowCoins :: forall era. AllegraEraScript era => NativeScript era
yellowCoins = Int -> NativeScript era
forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy Int
2

yellowCoinId :: PolicyID
yellowCoinId :: PolicyID
yellowCoinId = ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID) -> ScriptHash -> PolicyID
forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @MaryEra NativeScript MaryEra
Script MaryEra
forall era. AllegraEraScript era => NativeScript era
yellowCoins

yellowNumAssets :: Int
yellowNumAssets :: Int
yellowNumAssets = Int
5

genYellow :: Gen MultiAsset
genYellow :: Gen MultiAsset
genYellow = do
  xs <- [Int] -> Gen [Int]
forall a. [a] -> Gen [a]
QC.sublistOf [Int
0 .. Int
yellowNumAssets]
  as <- mapM genSingleYellow xs
  pure $ multiAssetFromList (map (\(AssetName
asset, Integer
count) -> (PolicyID
yellowCoinId, AssetName
asset, Integer
count)) as)
  where
    genSingleYellow :: a -> Gen (AssetName, Integer)
genSingleYellow a
x = do
      y <- Integer -> Integer -> Gen Integer
genInteger Integer
coloredCoinMinMint Integer
coloredCoinMaxMint
      let an = ShortByteString -> AssetName
AssetName (ShortByteString -> AssetName)
-> ([Char] -> ShortByteString) -> [Char] -> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShortByteString
forall a. IsString a => [Char] -> a
fromString ([Char] -> AssetName) -> [Char] -> AssetName
forall a b. (a -> b) -> a -> b
$ [Char]
"yellow" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> a -> [Char]
forall a. Show a => a -> [Char]
show a
x
      pure (an, y)

-- | Carefully crafted to apply in any Era where Value is MaryValue
-- | This map allows us to lookup a minting policy by the policy ID.
policyIndex :: AllegraEraScript era => Map PolicyID (NativeScript era)
policyIndex :: forall era. AllegraEraScript era => Map PolicyID (NativeScript era)
policyIndex =
  [(PolicyID, NativeScript era)] -> Map PolicyID (NativeScript era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (PolicyID
redCoinId, NativeScript era
forall era. AllegraEraScript era => NativeScript era
redCoins)
    , (PolicyID
blueCoinId, NativeScript era
forall era. AllegraEraScript era => NativeScript era
blueCoins)
    , (PolicyID
yellowCoinId, NativeScript era
forall era. AllegraEraScript era => NativeScript era
yellowCoins)
    ]

--------------------------------------------------------
-- Minting Frequencies                                --
--                                                    --
-- The frequencies represent a percent chance of any  --
-- given transaction to mint one of the three token   --
-- bundles.                                           --
--------------------------------------------------------

redFreq :: Int
redFreq :: Int
redFreq = Int
10

blueFreq :: Int
blueFreq :: Int
blueFreq = Int
1

yellowFreq :: Int
yellowFreq :: Int
yellowFreq = Int
20

genBundle :: Int -> Gen MultiAsset -> Gen MultiAsset
genBundle :: Int -> Gen MultiAsset -> Gen MultiAsset
genBundle Int
freq Gen MultiAsset
g = [(Int, Gen MultiAsset)] -> Gen MultiAsset
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency [(Int
freq, Gen MultiAsset
g), (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
freq, MultiAsset -> Gen MultiAsset
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiAsset
forall a. Monoid a => a
mempty)]

genMint :: Gen MultiAsset
genMint :: Gen MultiAsset
genMint = do
  r <- Int -> Gen MultiAsset -> Gen MultiAsset
genBundle Int
redFreq Gen MultiAsset
genRed
  b <- genBundle blueFreq genBlue
  y <- genBundle yellowFreq genYellow
  pure $ r <> b <> y

-------------------------------
-- END Permissionless Tokens --
-------------------------------

-- | Carefully crafted to apply to any Era where Value is MaryValue
-- We attempt to Add tokens to a non-empty list of transaction outputs.
-- It will add them to the first output that has enough lovelace
-- to meet the minUTxO requirment, if such an output exists.
addTokens ::
  forall era.
  ( EraGen era
  , Value era ~ MaryValue
  ) =>
  Proxy era ->
  StrictSeq (TxOut era) -> -- This is an accumuating parameter
  PParams era ->
  MultiAsset ->
  StrictSeq (TxOut era) ->
  Maybe (StrictSeq (TxOut era))
addTokens :: forall era.
(EraGen era, Value era ~ MaryValue) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset
-> StrictSeq (TxOut era)
-> Maybe (StrictSeq (TxOut era))
addTokens Proxy era
proxy StrictSeq (TxOut era)
tooLittleLovelace PParams era
pparams MultiAsset
ts (TxOut era
txOut :<| StrictSeq (TxOut era)
os) =
  if TxOut era
txOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< PParams era -> TxOut era -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
txOut
    then Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset
-> StrictSeq (TxOut era)
-> Maybe (StrictSeq (TxOut era))
forall era.
(EraGen era, Value era ~ MaryValue) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset
-> StrictSeq (TxOut era)
-> Maybe (StrictSeq (TxOut era))
addTokens Proxy era
proxy (TxOut era
txOut TxOut era -> StrictSeq (TxOut era) -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq (TxOut era)
tooLittleLovelace) PParams era
pparams MultiAsset
ts StrictSeq (TxOut era)
os
    else StrictSeq (TxOut era) -> Maybe (StrictSeq (TxOut era))
forall a. a -> Maybe a
Just (StrictSeq (TxOut era) -> Maybe (StrictSeq (TxOut era)))
-> StrictSeq (TxOut era) -> Maybe (StrictSeq (TxOut era))
forall a b. (a -> b) -> a -> b
$ StrictSeq (TxOut era)
tooLittleLovelace StrictSeq (TxOut era)
-> StrictSeq (TxOut era) -> StrictSeq (TxOut era)
forall a. StrictSeq a -> StrictSeq a -> StrictSeq a
>< forall era. MinGenTxout era => Value era -> TxOut era -> TxOut era
addValToTxOut @era (Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
ts) TxOut era
txOut TxOut era -> StrictSeq (TxOut era) -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a -> StrictSeq a
<| StrictSeq (TxOut era)
os
addTokens Proxy era
_proxy StrictSeq (TxOut era)
_ PParams era
_ MultiAsset
_ StrictSeq (TxOut era)
StrictSeq.Empty = Maybe (StrictSeq (TxOut era))
forall a. Maybe a
Nothing

-- | This function is only good in the Mary Era
genTxBody ::
  PParams MaryEra ->
  SlotNo ->
  Set.Set TxIn ->
  StrictSeq (ShelleyTxOut MaryEra) ->
  StrictSeq (TxCert MaryEra) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update MaryEra) ->
  StrictMaybe TxAuxDataHash ->
  Gen (TxBody TopTx MaryEra, [NativeScript MaryEra])
genTxBody :: PParams MaryEra
-> SlotNo
-> Set TxIn
-> StrictSeq (ShelleyTxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx MaryEra, [NativeScript MaryEra])
genTxBody PParams MaryEra
pparams SlotNo
slot Set TxIn
ins StrictSeq (ShelleyTxOut MaryEra)
outs StrictSeq (TxCert MaryEra)
cert Withdrawals
wdrl Coin
fee StrictMaybe (Update MaryEra)
upd StrictMaybe TxAuxDataHash
meta = do
  validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  mint <- genMint
  let (mint', outs') = case addTokens (Proxy @MaryEra) StrictSeq.Empty pparams mint outs of
        Maybe (StrictSeq (TxOut MaryEra))
Nothing -> (MultiAsset
forall a. Monoid a => a
mempty, StrictSeq (ShelleyTxOut MaryEra)
outs)
        Just StrictSeq (TxOut MaryEra)
os -> (MultiAsset
mint, StrictSeq (TxOut MaryEra)
StrictSeq (ShelleyTxOut MaryEra)
os)
      ps =
        (PolicyID -> Timelock MaryEra) -> [PolicyID] -> [Timelock MaryEra]
forall a b. (a -> b) -> [a] -> [b]
map (\PolicyID
k -> Timelock MaryEra
-> PolicyID -> Map PolicyID (Timelock MaryEra) -> Timelock MaryEra
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ([Char] -> Timelock MaryEra
forall a. HasCallStack => [Char] -> a
error ([Char] -> Timelock MaryEra) -> [Char] -> Timelock MaryEra
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot find policy: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PolicyID -> [Char]
forall a. Show a => a -> [Char]
show PolicyID
k) PolicyID
k Map PolicyID (Timelock MaryEra)
Map PolicyID (NativeScript MaryEra)
forall era. AllegraEraScript era => Map PolicyID (NativeScript era)
policyIndex) ([PolicyID] -> [Timelock MaryEra])
-> [PolicyID] -> [Timelock MaryEra]
forall a b. (a -> b) -> a -> b
$
          Set PolicyID -> [PolicyID]
forall a. Set a -> [a]
Set.toList (Set PolicyID -> [PolicyID]) -> Set PolicyID -> [PolicyID]
forall a b. (a -> b) -> a -> b
$
            MultiAsset -> Set PolicyID
policies MultiAsset
mint
  pure
    ( MaryTxBody
        ins
        outs'
        cert
        wdrl
        fee
        validityInterval
        upd
        meta
        mint'
    , ps -- These additional scripts are for the minting policies.
    )

instance Split MaryValue where
  vsplit :: MaryValue -> Integer -> ([MaryValue], Coin)
vsplit (MaryValue Coin
n MultiAsset
_) Integer
0 = ([], Coin
n)
  vsplit (MaryValue (Coin Integer
n) MultiAsset
mp) Integer
m
    | Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = [Char] -> ([MaryValue], Coin)
forall a. HasCallStack => [Char] -> a
error [Char]
"must split coins into positive parts"
    | Bool
otherwise =
        ( Int -> [MaryValue] -> [MaryValue]
forall a. Int -> [a] -> [a]
take
            (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m)
            (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
m)) MultiAsset
mp MaryValue -> [MaryValue] -> [MaryValue]
forall a. a -> [a] -> [a]
: MaryValue -> [MaryValue]
forall a. a -> [a]
repeat (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
m)) MultiAsset
forall a. Monoid a => a
mempty))
        , Integer -> Coin
Coin (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` Integer
m)
        )

instance MinGenTxout MaryEra where
  calcEraMinUTxO :: TxOut MaryEra -> PParams MaryEra -> Coin
calcEraMinUTxO TxOut MaryEra
_txout PParams MaryEra
pp = PParams MaryEra
pp PParams MaryEra -> Getting Coin (PParams MaryEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams MaryEra) Coin
forall era.
(EraPParams era, AtMostEra "Mary" era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams MaryEra) Coin
ppMinUTxOValueL
  addValToTxOut :: Value MaryEra -> TxOut MaryEra -> TxOut MaryEra
addValToTxOut Value MaryEra
v (ShelleyTxOut Addr
a Value MaryEra
u) = Addr -> Value MaryEra -> ShelleyTxOut MaryEra
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
a (Value MaryEra
MaryValue
v MaryValue -> MaryValue -> MaryValue
forall t. Val t => t -> t -> t
<+> Value MaryEra
MaryValue
u)
  genEraTxOut :: forall c.
GenEnv c MaryEra
-> Gen (Value MaryEra) -> [Addr] -> Gen [TxOut MaryEra]
genEraTxOut GenEnv c MaryEra
_genenv Gen (Value MaryEra)
genVal [Addr]
addrs = do
    values <- Int -> Gen MaryValue -> Gen [MaryValue]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Addr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value MaryEra)
Gen MaryValue
genVal
    let makeTxOut (Addr
addr, Value era
val) = Addr -> Value era -> ShelleyTxOut era
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
addr Value era
val
    pure (makeTxOut <$> zip addrs values)