{-# 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 (MaryTxBody (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) = forall a. a -> Maybe a
Just KeyHash 'Witness
hk
  isKey Proxy MaryEra
_ Script MaryEra
_ = 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
_ = forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL
  unQuantify :: Proxy MaryEra -> Quantifier (Script MaryEra) -> Script MaryEra
unQuantify Proxy MaryEra
_ = forall era.
AllegraEraScript era =>
Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL

instance EraGen MaryEra where
  genGenesisValue :: GenEnv MaryEra -> Gen (Value MaryEra)
genGenesisValue = forall era. GenEnv era -> Gen MaryValue
maryGenesisValue
  genEraTxBody :: GenEnv MaryEra
-> UTxO MaryEra
-> PParams MaryEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody MaryEra, [Script MaryEra])
genEraTxBody GenEnv MaryEra
_ge UTxO MaryEra
_utxo = forall era.
(EraGen era, AllegraEraScript era, Value era ~ MaryValue,
 TxOut era ~ ShelleyTxOut era) =>
PParams era
-> SlotNo
-> Set TxIn
-> StrictSeq (ShelleyTxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (MaryTxBody era, [NativeScript era])
genTxBody
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData MaryEra))
genEraAuxiliaryData = Constants -> Gen (StrictMaybe (TxAuxData MaryEra))
genAuxiliaryData
  updateEraTxBody :: UTxO MaryEra
-> PParams MaryEra
-> TxWits MaryEra
-> TxBody MaryEra
-> Coin
-> Set TxIn
-> TxOut MaryEra
-> TxBody MaryEra
updateEraTxBody UTxO MaryEra
_utxo PParams MaryEra
_pp TxWits MaryEra
_wits TxBody MaryEra
txBody Coin
fee Set TxIn
ins TxOut MaryEra
out =
    TxBody MaryEra
txBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set TxIn
ins
      forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut MaryEra
out)
      forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
  genEraPParamsUpdate :: Constants -> PParams MaryEra -> Gen (PParamsUpdate MaryEra)
genEraPParamsUpdate = forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate
  genEraPParams :: Constants -> Gen (PParams MaryEra)
genEraPParams = forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
Constants -> Gen (PParams era)
genPParams
  genEraTxWits :: (UTxO MaryEra, TxBody MaryEra, ScriptInfo MaryEra)
-> Set (WitVKey 'Witness)
-> Map ScriptHash (Script MaryEra)
-> TxWits MaryEra
genEraTxWits (UTxO MaryEra, TxBody MaryEra, ScriptInfo MaryEra)
_scriptinfo Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script MaryEra)
mapScriptWit = 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 forall a. Monoid a => a
mempty

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

-- | Carefully crafted to apply in any Era where Value is MaryValue
maryGenesisValue :: GenEnv era -> Gen MaryValue
maryGenesisValue :: forall era. GenEnv era -> Gen MaryValue
maryGenesisValue (GenEnv KeySpace era
_ ScriptSpace era
_ Constants {Integer
minGenesisOutputVal :: Constants -> Integer
minGenesisOutputVal :: Integer
minGenesisOutputVal, Integer
maxGenesisOutputVal :: Constants -> Integer
maxGenesisOutputVal :: Integer
maxGenesisOutputVal}) =
  forall t s. Inject t s => t -> s
Val.inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin 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 forall a. Eq a => a -> a -> Bool
== Int
0 = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (forall a. [a] -> StrictSeq a
StrictSeq.fromList [])
  | Bool
otherwise = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy (Int
i forall a. Num a => a -> a -> a
- Int
1)])

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

coloredCoinMaxMint :: Integer
coloredCoinMaxMint :: Integer
coloredCoinMaxMint = Integer
1000 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 = forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy Int
0

redCoinId :: PolicyID
redCoinId :: PolicyID
redCoinId = ScriptHash -> PolicyID
PolicyID forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @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
  Integer
n <- Integer -> Integer -> Gen Integer
genInteger Integer
coloredCoinMinMint Integer
coloredCoinMaxMint
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID
redCoinId, AssetName
red, Integer
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 = forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy Int
1

blueCoinId :: PolicyID
blueCoinId :: PolicyID
blueCoinId = ScriptHash -> PolicyID
PolicyID forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @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
  [(AssetName, Integer)]
as <- forall a. HasCallStack => Int -> Gen a -> Gen a
QC.resize Int
maxBlueMint forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
QC.listOf Gen (AssetName, Integer)
genSingleBlue
  -- the transaction size gets too big if we mint too many assets
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList (forall a b. (a -> b) -> [a] -> [b]
map (\(AssetName
asset, Integer
count) -> (PolicyID
blueCoinId, AssetName
asset, Integer
count)) [(AssetName, Integer)]
as)
  where
    genSingleBlue :: Gen (AssetName, Integer)
genSingleBlue = do
      Integer
n <- Integer -> Integer -> Gen Integer
genInteger Integer
coloredCoinMinMint Integer
coloredCoinMaxMint
      ShortByteString
a <- forall a. Arbitrary a => Gen a
arbitrary
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShortByteString -> AssetName
AssetName ShortByteString
a, Integer
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 = forall era. AllegraEraScript era => Int -> NativeScript era
trivialPolicy Int
2

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

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

genYellow :: Gen MultiAsset
genYellow :: Gen MultiAsset
genYellow = do
  [Int]
xs <- forall a. [a] -> Gen [a]
QC.sublistOf [Int
0 .. Int
yellowNumAssets]
  [(AssetName, Integer)]
as <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. Show a => a -> Gen (AssetName, Integer)
genSingleYellow [Int]
xs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList (forall a b. (a -> b) -> [a] -> [b]
map (\(AssetName
asset, Integer
count) -> (PolicyID
yellowCoinId, AssetName
asset, Integer
count)) [(AssetName, Integer)]
as)
  where
    genSingleYellow :: a -> Gen (AssetName, Integer)
genSingleYellow a
x = do
      Integer
y <- Integer -> Integer -> Gen Integer
genInteger Integer
coloredCoinMinMint Integer
coloredCoinMaxMint
      let an :: AssetName
an = ShortByteString -> AssetName
AssetName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
"yellow" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (AssetName
an, Integer
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 =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (PolicyID
redCoinId, forall era. AllegraEraScript era => NativeScript era
redCoins)
    , (PolicyID
blueCoinId, forall era. AllegraEraScript era => NativeScript era
blueCoins)
    , (PolicyID
yellowCoinId, 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 = forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency [(Int
freq, Gen MultiAsset
g), (Int
100 forall a. Num a => a -> a -> a
- Int
freq, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty)]

genMint :: Gen MultiAsset
genMint :: Gen MultiAsset
genMint = do
  MultiAsset
r <- Int -> Gen MultiAsset -> Gen MultiAsset
genBundle Int
redFreq Gen MultiAsset
genRed
  MultiAsset
b <- Int -> Gen MultiAsset -> Gen MultiAsset
genBundle Int
blueFreq Gen MultiAsset
genBlue
  MultiAsset
y <- Int -> Gen MultiAsset -> Gen MultiAsset
genBundle Int
yellowFreq Gen MultiAsset
genYellow
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MultiAsset
r forall a. Semigroup a => a -> a -> a
<> MultiAsset
b forall a. Semigroup a => a -> a -> a
<> MultiAsset
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 forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall a. Ord a => a -> a -> Bool
< forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
txOut
    then 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 forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq (TxOut era)
tooLittleLovelace) PParams era
pparams MultiAsset
ts StrictSeq (TxOut era)
os
    else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ StrictSeq (TxOut era)
tooLittleLovelace forall a. StrictSeq a -> StrictSeq a -> StrictSeq a
>< forall era. MinGenTxout era => Value era -> TxOut era -> TxOut era
addValToTxOut @era (Coin -> MultiAsset -> MaryValue
MaryValue forall a. Monoid a => a
mempty MultiAsset
ts) TxOut era
txOut 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 = forall a. Maybe a
Nothing

-- | This function is only good in the Mary Era
genTxBody ::
  forall era.
  ( EraGen era
  , AllegraEraScript era
  , Value era ~ MaryValue
  , TxOut era ~ ShelleyTxOut era
  ) =>
  PParams era ->
  SlotNo ->
  Set.Set TxIn ->
  StrictSeq (ShelleyTxOut era) ->
  StrictSeq (TxCert era) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update era) ->
  StrictMaybe TxAuxDataHash ->
  Gen (MaryTxBody era, [NativeScript era])
genTxBody :: forall era.
(EraGen era, AllegraEraScript era, Value era ~ MaryValue,
 TxOut era ~ ShelleyTxOut era) =>
PParams era
-> SlotNo
-> Set TxIn
-> StrictSeq (ShelleyTxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (MaryTxBody era, [NativeScript era])
genTxBody PParams era
pparams SlotNo
slot Set TxIn
ins StrictSeq (ShelleyTxOut era)
outs StrictSeq (TxCert era)
cert Withdrawals
wdrl Coin
fee StrictMaybe (Update era)
upd StrictMaybe TxAuxDataHash
meta = do
  ValidityInterval
validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  MultiAsset
mint <- Gen MultiAsset
genMint
  let (MultiAsset
mint', StrictSeq (ShelleyTxOut era)
outs') = case forall era.
(EraGen era, Value era ~ MaryValue) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset
-> StrictSeq (TxOut era)
-> Maybe (StrictSeq (TxOut era))
addTokens (forall {k} (t :: k). Proxy t
Proxy @era) forall a. StrictSeq a
StrictSeq.Empty PParams era
pparams MultiAsset
mint StrictSeq (ShelleyTxOut era)
outs of
        Maybe (StrictSeq (TxOut era))
Nothing -> (forall a. Monoid a => a
mempty, StrictSeq (ShelleyTxOut era)
outs)
        Just StrictSeq (TxOut era)
os -> (MultiAsset
mint, StrictSeq (TxOut era)
os)
      ps :: [NativeScript era]
ps =
        forall a b. (a -> b) -> [a] -> [b]
map (\PolicyID
k -> forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Cannot find policy: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PolicyID
k) PolicyID
k forall era. AllegraEraScript era => Map PolicyID (NativeScript era)
policyIndex) forall a b. (a -> b) -> a -> b
$
          forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
            MultiAsset -> Set PolicyID
policies MultiAsset
mint
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall era.
(EraTxOut era, EraTxCert era) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> MultiAsset
-> MaryTxBody era
MaryTxBody
        Set TxIn
ins
        StrictSeq (ShelleyTxOut era)
outs'
        StrictSeq (TxCert era)
cert
        Withdrawals
wdrl
        Coin
fee
        ValidityInterval
validityInterval
        StrictMaybe (Update era)
upd
        StrictMaybe TxAuxDataHash
meta
        MultiAsset
mint'
    , [NativeScript era]
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 forall a. Ord a => a -> a -> Bool
<= Integer
0 = forall a. HasCallStack => String -> a
error String
"must split coins into positive parts"
    | Bool
otherwise =
        ( forall a. Int -> [a] -> [a]
take
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m)
            (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin (Integer
n forall a. Integral a => a -> a -> a
`div` Integer
m)) MultiAsset
mp forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin (Integer
n forall a. Integral a => a -> a -> a
`div` Integer
m)) forall a. Monoid a => a
mempty))
        , Integer -> Coin
Coin (Integer
n 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 forall s a. s -> Getting a s a -> a
^. forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL
  addValToTxOut :: Value MaryEra -> TxOut MaryEra -> TxOut MaryEra
addValToTxOut Value MaryEra
v (ShelleyTxOut Addr
a Value MaryEra
u) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
a (Value MaryEra
v forall t. Val t => t -> t -> t
<+> Value MaryEra
u)
  genEraTxOut :: GenEnv MaryEra
-> Gen (Value MaryEra) -> [Addr] -> Gen [TxOut MaryEra]
genEraTxOut GenEnv MaryEra
_genenv Gen (Value MaryEra)
genVal [Addr]
addrs = do
    [MaryValue]
values <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value MaryEra)
genVal
    let makeTxOut :: (Addr, Value era) -> ShelleyTxOut era
makeTxOut (Addr
addr, Value era
val) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
addr Value era
val
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {era}.
(Era era, Val (Value era)) =>
(Addr, Value era) -> ShelleyTxOut era
makeTxOut forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Addr]
addrs [MaryValue]
values)