{-# 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
_ = Script MaryEra -> Quantifier (Script MaryEra)
NativeScript MaryEra -> Quantifier (NativeScript MaryEra)
forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL
  unQuantify :: Proxy MaryEra -> Quantifier (Script MaryEra) -> Script MaryEra
unQuantify Proxy MaryEra
_ = Quantifier (Script MaryEra) -> Script MaryEra
Quantifier (NativeScript MaryEra) -> NativeScript 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 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 MaryEra, [Script MaryEra])
PParams MaryEra
-> SlotNo
-> Set TxIn
-> StrictSeq (ShelleyTxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody 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 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
      TxBody MaryEra
-> (TxBody MaryEra -> TxBody MaryEra) -> TxBody MaryEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody MaryEra -> Identity (TxBody MaryEra)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody MaryEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody MaryEra -> Identity (TxBody MaryEra))
-> Set TxIn -> TxBody MaryEra -> TxBody MaryEra
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set TxIn
ins
      TxBody MaryEra
-> (TxBody MaryEra -> TxBody MaryEra) -> TxBody MaryEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut MaryEra) -> Identity (StrictSeq (TxOut MaryEra)))
-> TxBody MaryEra -> Identity (TxBody MaryEra)
(StrictSeq (ShelleyTxOut MaryEra)
 -> Identity (StrictSeq (ShelleyTxOut MaryEra)))
-> TxBody MaryEra -> Identity (TxBody MaryEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody MaryEra) (StrictSeq (TxOut MaryEra))
outputsTxBodyL ((StrictSeq (ShelleyTxOut MaryEra)
  -> Identity (StrictSeq (ShelleyTxOut MaryEra)))
 -> TxBody MaryEra -> Identity (TxBody MaryEra))
-> (StrictSeq (ShelleyTxOut MaryEra)
    -> StrictSeq (ShelleyTxOut MaryEra))
-> TxBody MaryEra
-> TxBody 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 MaryEra
-> (TxBody MaryEra -> TxBody MaryEra) -> TxBody MaryEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody MaryEra -> Identity (TxBody MaryEra)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody MaryEra) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody MaryEra -> Identity (TxBody MaryEra))
-> Coin -> TxBody MaryEra -> TxBody 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.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate
  genEraPParams :: Constants -> Gen (PParams MaryEra)
genEraPParams = Constants -> Gen (PParams MaryEra)
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 = 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 Script MaryEra
NativeScript 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
  MultiAsset -> Gen MultiAsset
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiAsset -> Gen MultiAsset) -> MultiAsset -> Gen MultiAsset
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 = 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 Script MaryEra
NativeScript 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 <- 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
  MultiAsset -> Gen MultiAsset
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiAsset -> Gen MultiAsset) -> MultiAsset -> Gen MultiAsset
forall a b. (a -> b) -> a -> b
$ [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList (((AssetName, Integer) -> (PolicyID, AssetName, Integer))
-> [(AssetName, Integer)] -> [(PolicyID, AssetName, Integer)]
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 <- Gen ShortByteString
forall a. Arbitrary a => Gen a
arbitrary
      (AssetName, Integer) -> Gen (AssetName, Integer)
forall a. a -> Gen a
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 = 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 Script MaryEra
NativeScript 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 <- [Int] -> Gen [Int]
forall a. [a] -> Gen [a]
QC.sublistOf [Int
0 .. Int
yellowNumAssets]
  [(AssetName, Integer)]
as <- (Int -> Gen (AssetName, Integer))
-> [Int] -> Gen [(AssetName, Integer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> Gen (AssetName, Integer)
forall {a}. Show a => a -> Gen (AssetName, Integer)
genSingleYellow [Int]
xs
  MultiAsset -> Gen MultiAsset
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiAsset -> Gen MultiAsset) -> MultiAsset -> Gen MultiAsset
forall a b. (a -> b) -> a -> b
$ [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList (((AssetName, Integer) -> (PolicyID, AssetName, Integer))
-> [(AssetName, Integer)] -> [(PolicyID, AssetName, Integer)]
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 (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
      (AssetName, Integer) -> Gen (AssetName, Integer)
forall a. a -> Gen a
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 =
  [(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
  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
  MultiAsset -> Gen MultiAsset
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiAsset -> Gen MultiAsset) -> MultiAsset -> Gen MultiAsset
forall a b. (a -> b) -> a -> b
$ MultiAsset
r MultiAsset -> MultiAsset -> MultiAsset
forall a. Semigroup a => a -> a -> a
<> MultiAsset
b MultiAsset -> MultiAsset -> MultiAsset
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 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 MaryEra, [NativeScript MaryEra])
genTxBody :: PParams MaryEra
-> SlotNo
-> Set TxIn
-> StrictSeq (ShelleyTxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody 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
validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  MultiAsset
mint <- Gen MultiAsset
genMint
  let (MultiAsset
mint', StrictSeq (ShelleyTxOut MaryEra)
outs') = case Proxy MaryEra
-> StrictSeq (TxOut MaryEra)
-> PParams MaryEra
-> MultiAsset
-> StrictSeq (TxOut MaryEra)
-> Maybe (StrictSeq (TxOut MaryEra))
forall era.
(EraGen era, Value era ~ MaryValue) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset
-> StrictSeq (TxOut era)
-> Maybe (StrictSeq (TxOut era))
addTokens (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MaryEra) StrictSeq (TxOut MaryEra)
StrictSeq (ShelleyTxOut MaryEra)
forall a. StrictSeq a
StrictSeq.Empty PParams MaryEra
pparams MultiAsset
mint StrictSeq (TxOut MaryEra)
StrictSeq (ShelleyTxOut MaryEra)
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 :: [Timelock MaryEra]
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
  (TxBody MaryEra, [Timelock MaryEra])
-> Gen (TxBody MaryEra, [Timelock MaryEra])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Set TxIn
-> StrictSeq (TxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> MultiAsset
-> TxBody MaryEra
(EraTxOut MaryEra, EraTxCert MaryEra) =>
Set TxIn
-> StrictSeq (TxOut MaryEra)
-> StrictSeq (TxCert MaryEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update MaryEra)
-> StrictMaybe TxAuxDataHash
-> MultiAsset
-> TxBody MaryEra
MaryTxBody
        Set TxIn
ins
        StrictSeq (TxOut MaryEra)
StrictSeq (ShelleyTxOut MaryEra)
outs'
        StrictSeq (TxCert MaryEra)
cert
        Withdrawals
wdrl
        Coin
fee
        ValidityInterval
validityInterval
        StrictMaybe (Update MaryEra)
upd
        StrictMaybe TxAuxDataHash
meta
        MultiAsset
mint'
    , [Timelock MaryEra]
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, ProtVerAtMost era 4) =>
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
    [MaryValue]
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, Value era) -> ShelleyTxOut era
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
    [ShelleyTxOut MaryEra] -> Gen [ShelleyTxOut MaryEra]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Addr, Value MaryEra) -> ShelleyTxOut MaryEra
(Addr, MaryValue) -> ShelleyTxOut MaryEra
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Era era, Val (Value era)) =>
(Addr, Value era) -> ShelleyTxOut era
makeTxOut ((Addr, MaryValue) -> ShelleyTxOut MaryEra)
-> [(Addr, MaryValue)] -> [ShelleyTxOut MaryEra]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Addr] -> [MaryValue] -> [(Addr, MaryValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Addr]
addrs [MaryValue]
values)