{-# 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.AuxiliaryData (AuxiliaryDataHash)
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto
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 c)

 This instance is layered on top of the ShelleyMA instances
 in Cardano.Ledger.ShelleyMA.Scripts:

   `type instance Script (MaryEra c) = Timelock (MaryEra c)`
   `instance ValidateScript (ShelleyMAEra ma c) where ... `
------------------------------------------------------------------------------}

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

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

genAuxiliaryData :: Crypto c => Constants -> Gen (StrictMaybe (TxAuxData (MaryEra c)))
genAuxiliaryData :: forall c.
Crypto c =>
Constants -> Gen (StrictMaybe (TxAuxData (MaryEra c)))
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 c)
maryGenesisValue :: forall era c. GenEnv era -> Gen (MaryValue c)
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 :: forall c. Crypto c => PolicyID c
redCoinId :: forall c. Crypto c => PolicyID c
redCoinId = forall c. ScriptHash c -> PolicyID c
PolicyID forall a b. (a -> b) -> a -> b
$ forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @(MaryEra c) forall era. AllegraEraScript era => NativeScript era
redCoins

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

genRed :: Crypto c => Gen (MultiAsset c)
genRed :: forall c. Crypto c => Gen (MultiAsset c)
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
$ forall era. [(PolicyID era, AssetName, Integer)] -> MultiAsset era
multiAssetFromList [(forall c. Crypto c => PolicyID c
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 :: forall c. Crypto c => PolicyID c
blueCoinId :: forall c. Crypto c => PolicyID c
blueCoinId = forall c. ScriptHash c -> PolicyID c
PolicyID forall a b. (a -> b) -> a -> b
$ forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @(MaryEra c) 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 :: Crypto c => Gen (MultiAsset c)
genBlue :: forall c. Crypto c => Gen (MultiAsset c)
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
$ forall era. [(PolicyID era, AssetName, Integer)] -> MultiAsset era
multiAssetFromList (forall a b. (a -> b) -> [a] -> [b]
map (\(AssetName
asset, Integer
count) -> (forall c. Crypto c => PolicyID c
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 :: forall c. Crypto c => PolicyID c
yellowCoinId :: forall c. Crypto c => PolicyID c
yellowCoinId = forall c. ScriptHash c -> PolicyID c
PolicyID forall a b. (a -> b) -> a -> b
$ forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @(MaryEra c) forall era. AllegraEraScript era => NativeScript era
yellowCoins

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

genYellow :: Crypto c => Gen (MultiAsset c)
genYellow :: forall c. Crypto c => Gen (MultiAsset c)
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
$ forall era. [(PolicyID era, AssetName, Integer)] -> MultiAsset era
multiAssetFromList (forall a b. (a -> b) -> [a] -> [b]
map (\(AssetName
asset, Integer
count) -> (forall c. Crypto c => PolicyID c
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 (EraCrypto era)) (NativeScript era)
policyIndex :: forall era.
AllegraEraScript era =>
Map (PolicyID (EraCrypto era)) (NativeScript era)
policyIndex =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (forall c. Crypto c => PolicyID c
redCoinId, forall era. AllegraEraScript era => NativeScript era
redCoins)
    , (forall c. Crypto c => PolicyID c
blueCoinId, forall era. AllegraEraScript era => NativeScript era
blueCoins)
    , (forall c. Crypto c => PolicyID c
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 c) -> Gen (MultiAsset c)
genBundle :: forall c. Int -> Gen (MultiAsset c) -> Gen (MultiAsset c)
genBundle Int
freq Gen (MultiAsset c)
g = forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency [(Int
freq, Gen (MultiAsset c)
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 :: Crypto c => Gen (MultiAsset c)
genMint :: forall c. Crypto c => Gen (MultiAsset c)
genMint = do
  MultiAsset c
r <- forall c. Int -> Gen (MultiAsset c) -> Gen (MultiAsset c)
genBundle Int
redFreq forall c. Crypto c => Gen (MultiAsset c)
genRed
  MultiAsset c
b <- forall c. Int -> Gen (MultiAsset c) -> Gen (MultiAsset c)
genBundle Int
blueFreq forall c. Crypto c => Gen (MultiAsset c)
genBlue
  MultiAsset c
y <- forall c. Int -> Gen (MultiAsset c) -> Gen (MultiAsset c)
genBundle Int
yellowFreq forall c. Crypto c => Gen (MultiAsset c)
genYellow
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MultiAsset c
r forall a. Semigroup a => a -> a -> a
<> MultiAsset c
b forall a. Semigroup a => a -> a -> a
<> MultiAsset c
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 (EraCrypto era)
  ) =>
  Proxy era ->
  StrictSeq (TxOut era) -> -- This is an accumuating parameter
  PParams era ->
  MultiAsset (EraCrypto era) ->
  StrictSeq (TxOut era) ->
  Maybe (StrictSeq (TxOut era))
addTokens :: forall era.
(EraGen era, Value era ~ MaryValue (EraCrypto era)) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset (EraCrypto era)
-> StrictSeq (TxOut era)
-> Maybe (StrictSeq (TxOut era))
addTokens Proxy era
proxy StrictSeq (TxOut era)
tooLittleLovelace PParams era
pparams MultiAsset (EraCrypto era)
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 (EraCrypto era)) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset (EraCrypto era)
-> 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 (EraCrypto era)
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 (forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue forall a. Monoid a => a
mempty MultiAsset (EraCrypto era)
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 (EraCrypto era)
_ 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 (EraCrypto era)
  , TxOut era ~ ShelleyTxOut era
  ) =>
  PParams era ->
  SlotNo ->
  Set.Set (TxIn (EraCrypto era)) ->
  StrictSeq (ShelleyTxOut era) ->
  StrictSeq (TxCert era) ->
  Withdrawals (EraCrypto era) ->
  Coin ->
  StrictMaybe (Update era) ->
  StrictMaybe (AuxiliaryDataHash (EraCrypto era)) ->
  Gen (MaryTxBody era, [NativeScript era])
genTxBody :: forall era.
(EraGen era, AllegraEraScript era,
 Value era ~ MaryValue (EraCrypto era),
 TxOut era ~ ShelleyTxOut era) =>
PParams era
-> SlotNo
-> Set (TxIn (EraCrypto era))
-> StrictSeq (ShelleyTxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> Gen (MaryTxBody era, [NativeScript era])
genTxBody PParams era
pparams SlotNo
slot Set (TxIn (EraCrypto era))
ins StrictSeq (ShelleyTxOut era)
outs StrictSeq (TxCert era)
cert Withdrawals (EraCrypto era)
wdrl Coin
fee StrictMaybe (Update era)
upd StrictMaybe (AuxiliaryDataHash (EraCrypto era))
meta = do
  ValidityInterval
validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  MultiAsset (EraCrypto era)
mint <- forall c. Crypto c => Gen (MultiAsset c)
genMint
  let (MultiAsset (EraCrypto era)
mint', StrictSeq (ShelleyTxOut era)
outs') = case forall era.
(EraGen era, Value era ~ MaryValue (EraCrypto era)) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset (EraCrypto era)
-> 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 (EraCrypto era)
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 (EraCrypto era)
mint, StrictSeq (TxOut era)
os)
      ps :: [NativeScript era]
ps =
        forall a b. (a -> b) -> [a] -> [b]
map (\PolicyID (EraCrypto era)
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 (EraCrypto era)
k) PolicyID (EraCrypto era)
k forall era.
AllegraEraScript era =>
Map (PolicyID (EraCrypto era)) (NativeScript era)
policyIndex) forall a b. (a -> b) -> a -> b
$
          forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
            forall c. MultiAsset c -> Set (PolicyID c)
policies MultiAsset (EraCrypto era)
mint
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall era.
(EraTxOut era, EraTxCert era) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> MultiAsset (EraCrypto era)
-> MaryTxBody era
MaryTxBody
        Set (TxIn (EraCrypto era))
ins
        StrictSeq (ShelleyTxOut era)
outs'
        StrictSeq (TxCert era)
cert
        Withdrawals (EraCrypto era)
wdrl
        Coin
fee
        ValidityInterval
validityInterval
        StrictMaybe (Update era)
upd
        StrictMaybe (AuxiliaryDataHash (EraCrypto era))
meta
        MultiAsset (EraCrypto era)
mint'
    , [NativeScript era]
ps -- These additional scripts are for the minting policies.
    )

instance Split (MaryValue era) where
  vsplit :: MaryValue era -> Integer -> ([MaryValue era], Coin)
vsplit (MaryValue Coin
n MultiAsset era
_) Integer
0 = ([], Coin
n)
  vsplit (MaryValue (Coin Integer
n) MultiAsset era
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)
            (forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue (Integer -> Coin
Coin (Integer
n forall a. Integral a => a -> a -> a
`div` Integer
m)) MultiAsset era
mp forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat (forall c. Coin -> MultiAsset c -> MaryValue c
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 Crypto c => MinGenTxout (MaryEra c) where
  calcEraMinUTxO :: TxOut (MaryEra c) -> PParams (MaryEra c) -> Coin
calcEraMinUTxO TxOut (MaryEra c)
_txout PParams (MaryEra c)
pp = PParams (MaryEra c)
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 c) -> TxOut (MaryEra c) -> TxOut (MaryEra c)
addValToTxOut Value (MaryEra c)
v (ShelleyTxOut Addr (EraCrypto (MaryEra c))
a Value (MaryEra c)
u) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr (EraCrypto (MaryEra c))
a (Value (MaryEra c)
v forall t. Val t => t -> t -> t
<+> Value (MaryEra c)
u)
  genEraTxOut :: GenEnv (MaryEra c)
-> Gen (Value (MaryEra c))
-> [Addr (EraCrypto (MaryEra c))]
-> Gen [TxOut (MaryEra c)]
genEraTxOut GenEnv (MaryEra c)
_genenv Gen (Value (MaryEra c))
genVal [Addr (EraCrypto (MaryEra c))]
addrs = do
    [MaryValue c]
values <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr (EraCrypto (MaryEra c))]
addrs) Gen (Value (MaryEra c))
genVal
    let makeTxOut :: (Addr (EraCrypto era), Value era) -> ShelleyTxOut era
makeTxOut (Addr (EraCrypto era)
addr, Value era
val) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr (EraCrypto era)
addr Value era
val
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {era}.
(Era era, Val (Value era)) =>
(Addr (EraCrypto era), 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 (EraCrypto (MaryEra c))]
addrs [MaryValue c]
values)