{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Shelley.Generator.Utxo (
  genTx,
  Delta (..),
  encodedLen,
  pickRandomFromMap,
)
where

import Cardano.Ledger.Address (
  Addr (..),
  RewardAccount (..),
 )
import Cardano.Ledger.BaseTypes (
  Network (..),
  inject,
  maybeToStrictMaybe,
 )
import Cardano.Ledger.Binary (EncCBOR, serialize)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Keys (
  KeyHash,
  KeyRole (..),
  asWitness,
 )
import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated)
import Cardano.Ledger.Shelley.LedgerState (
  CertState (..),
  DState (..),
  LedgerState (..),
  UTxOState (..),
  certDState,
  ptrsMap,
  rewards,
 )
import Cardano.Ledger.Shelley.Rules (DelplEnv, LedgerEnv (..))
import Cardano.Ledger.Shelley.TxBody (Withdrawals (..))
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (
  EraUTxO,
  UTxO (..),
  getMinFeeTxUtxo,
  sumAllValue,
 )
import Cardano.Ledger.Val (Val (..), sumVal, (<+>), (<->), (<×>))
import Control.Monad (when)
import Control.State.Transition
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Either as Either (partitionEithers)
import Data.Foldable as F (foldl')
import qualified Data.IntSet as IntSet
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (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 qualified Data.Vector as V
import Lens.Micro
import NoThunks.Class ()
import Test.Cardano.Ledger.Binary.Random (QC (..))
import Test.Cardano.Ledger.Common (tracedDiscard)
import Test.Cardano.Ledger.Core.Arbitrary (uniformSubMapElems)
import Test.Cardano.Ledger.Core.KeyPair (
  KeyPair,
  KeyPairs,
  makeWitnessesFromScriptKeys,
  mkCred,
  mkWitnessesVKey,
 )
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (
  Mock,
 )
import Test.Cardano.Ledger.Shelley.Constants (Constants (..), defaultConstants)
import Test.Cardano.Ledger.Shelley.Generator.Core (
  GenEnv (..),
  KeySpace (..),
  ScriptInfo,
  ScriptSpace (..),
  findPayKeyPairAddr,
  findPayKeyPairCred,
  findPayScriptFromAddr,
  findStakeScriptFromCred,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (scriptKeyCombination)
import Test.Cardano.Ledger.Shelley.Generator.Trace.TxCert (CERTS, genTxCerts)
import Test.Cardano.Ledger.Shelley.Generator.Update (genUpdate)
import Test.Cardano.Ledger.Shelley.Utils (Split (..))
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck as QC

-- Instances only

-- ====================================================

-- | Generates a transaction in the context of the LEDGER STS environment
-- and state.
--
--  A generated transaction may not have sufficient spending balance and
-- need to be discarded. In that case we try to compute a Delta, that when
-- added (applyDelta) to the transaction, repairs it. The repair is made
-- by adding additional inputs from which more Ada can flow into the fee.
-- If that doesn't fix it, we add more inputs to the Delta.
-- Experience shows that this converges quite quickly (in traces we never saw
-- more than 3 iterations).

-- Note: the spending balance emerges from inputs, refund withdrawals,
-- certificate deposits and fees (which in turn depend on number of
-- inputs, outputs, witnesses, metadata etc.). It's hard to avoid this
-- completely, but in practice it is relatively easy to calibrate
-- the generator 'Constants' so that there is sufficient spending balance.

genTx ::
  forall era.
  ( EraGen era
  , EraUTxO era
  , Mock (EraCrypto era)
  , Embed (EraRule "DELPL" era) (CERTS era)
  , Environment (EraRule "DELPL" era) ~ DelplEnv era
  , State (EraRule "DELPL" era) ~ CertState era
  , Signal (EraRule "DELPL" era) ~ TxCert era
  ) =>
  GenEnv era ->
  LedgerEnv era ->
  LedgerState era ->
  Gen (Tx era)
genTx :: forall era.
(EraGen era, EraUTxO era, Mock (EraCrypto era),
 Embed (EraRule "DELPL" era) (CERTS era),
 Environment (EraRule "DELPL" era) ~ DelplEnv era,
 State (EraRule "DELPL" era) ~ CertState era,
 Signal (EraRule "DELPL" era) ~ TxCert era) =>
GenEnv era -> LedgerEnv era -> LedgerState era -> Gen (Tx era)
genTx
  ge :: GenEnv era
ge@( GenEnv
        keySpace :: KeySpace era
keySpace@KeySpace_
          { KeyPairs (EraCrypto era)
ksKeyPairs :: forall era. KeySpace era -> KeyPairs (EraCrypto era)
ksKeyPairs :: KeyPairs (EraCrypto era)
ksKeyPairs
          , [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes :: forall era.
KeySpace era
-> [(GenesisKeyPair (EraCrypto era),
     AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes
          , [(Script era, Script era)]
ksMSigScripts :: forall era. KeySpace era -> [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
ksMSigScripts
          , Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates :: forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate (EraCrypto era))
     (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates
          , Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys :: forall era.
KeySpace era
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys :: Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys
          , Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys :: forall era.
KeySpace era
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys :: Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
          , Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts :: forall era.
KeySpace era
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts :: Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts
          , Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts :: forall era.
KeySpace era
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts :: Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts
          }
        ScriptSpace era
scriptspace
        Constants
constants
      )
  (LedgerEnv SlotNo
slot Maybe EpochNo
_ TxIx
txIx PParams era
pparams AccountState
reserves Bool
_)
  (LedgerState utxoSt :: UTxOState era
utxoSt@(UTxOState UTxO era
utxo Coin
_ Coin
_ GovState era
_ IncrementalStake (EraCrypto era)
_ Coin
_) CertState era
dpState) =
    do
      -------------------------------------------------------------------------
      -- Generate the building blocks of a TxBody
      -------------------------------------------------------------------------
      ([TxIn (EraCrypto era)]
inputs, Value era
spendingBalanceUtxo, ([KeyPair 'Witness (EraCrypto era)]
spendWits, [(Script era, Script era)]
spendScripts)) <-
        forall era.
EraTxOut era =>
(Int, Int)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn (EraCrypto era)], Value era,
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genInputs
          (Constants -> Int
minNumGenInputs Constants
constants, Constants -> Int
maxNumGenInputs Constants
constants)
          Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys
          Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts
          UTxO era
utxo
      ([(RewardAccount (EraCrypto era), Coin)]
wdrls, ([KeyPair 'Witness (EraCrypto era)]
wdrlWits, [(Script era, Script era)]
wdrlScripts)) <-
        forall era.
Constants
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Gen
     ([(RewardAccount (EraCrypto era), Coin)],
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genWithdrawals
          @era
          Constants
constants
          Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts
          Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
          ((forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a. Compactible a => CompactForm a -> a
UM.fromCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. RDPair -> CompactForm Coin
UM.rdReward) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c k v. UView c k v -> Map k v
UM.unUnify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
DState era
-> UView
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState) CertState era
dpState)
      (Maybe (Update era)
update, [KeyPair 'Witness (EraCrypto era)]
updateWits) <-
        forall era.
EraGen era =>
Constants
-> SlotNo
-> [(GenesisKeyPair (EraCrypto era),
     AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
-> Map
     (KeyHash 'GenesisDelegate (EraCrypto era))
     (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
-> PParams era
-> (UTxOState era, CertState era)
-> Gen (Maybe (Update era), [KeyPair 'Witness (EraCrypto era)])
genUpdate
          Constants
constants
          SlotNo
slot
          [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes
          Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates
          PParams era
pparams
          (UTxOState era
utxoSt, CertState era
dpState)
      ([TxCert era]
certs, Coin
deposits, Coin
refunds, CertState era
dpState', [KeyPair 'Witness (EraCrypto era)]
certWits, [(Script era, Script era)]
certScripts) <-
        forall era.
(EraGen era, Embed (EraRule "DELPL" era) (CERTS era),
 Environment (EraRule "DELPL" era) ~ DelplEnv era,
 State (EraRule "DELPL" era) ~ CertState era,
 Signal (EraRule "DELPL" era) ~ TxCert era) =>
GenEnv era
-> PParams era
-> CertState era
-> SlotNo
-> TxIx
-> AccountState
-> Gen
     ([TxCert era], Coin, Coin, CertState era,
      [KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)])
genTxCerts GenEnv era
ge PParams era
pparams CertState era
dpState SlotNo
slot TxIx
txIx AccountState
reserves
      StrictMaybe (TxAuxData era)
metadata <- forall era.
EraGen era =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genEraAuxiliaryData @era Constants
constants
      -------------------------------------------------------------------------
      -- Gather Key TxWits and Scripts, prepare a constructor for Tx Wits
      -------------------------------------------------------------------------
      let txWits :: [KeyPair 'Witness (EraCrypto era)]
txWits = [KeyPair 'Witness (EraCrypto era)]
spendWits forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness (EraCrypto era)]
wdrlWits forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness (EraCrypto era)]
certWits forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness (EraCrypto era)]
updateWits
          scripts :: Map (ScriptHash (EraCrypto era)) (Script era)
scripts = forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
mkScriptWits @era [(Script era, Script era)]
spendScripts ([(Script era, Script era)]
certScripts forall a. [a] -> [a] -> [a]
++ [(Script era, Script era)]
wdrlScripts)
          mkTxWits' :: TxBody era -> TxWits era
mkTxWits' TxBody era
txbody =
            forall era.
(EraGen era, Mock (EraCrypto era)) =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> SafeHash (EraCrypto era) EraIndependentTxBody
-> TxWits era
mkTxWits @era
              (UTxO era
utxo, TxBody era
txbody, (forall era.
ScriptSpace era
-> Map (ScriptHash (EraCrypto era)) (TwoPhase3ArgInfo era)
ssHash3 ScriptSpace era
scriptspace, forall era.
ScriptSpace era
-> Map (ScriptHash (EraCrypto era)) (TwoPhase2ArgInfo era)
ssHash2 ScriptSpace era
scriptspace))
              Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys
              Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
              [KeyPair 'Witness (EraCrypto era)]
txWits
              Map (ScriptHash (EraCrypto era)) (Script era)
scripts
              (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txbody)
      -------------------------------------------------------------------------
      -- SpendingBalance, Output Addresses (including some Pointer addresses)
      -- and a Outputs builder that distributes the given balance over
      -- addresses.
      -------------------------------------------------------------------------
      let withdrawals :: Coin
withdrawals = forall (t :: * -> *) v. (Foldable t, Val v) => t v -> v
sumVal (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RewardAccount (EraCrypto era), Coin)]
wdrls)
          !spendingBalance :: Value era
spendingBalance =
            Value era
spendingBalanceUtxo
              forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
inject ((Coin
withdrawals forall t. Val t => t -> t -> t
<-> Coin
deposits) forall t. Val t => t -> t -> t
<+> Coin
refunds)
          n :: Int
n =
            if forall k a. Map k a -> Int
Map.size (forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO UTxO era
utxo) forall a. Ord a => a -> a -> Bool
< Constants -> Int
genTxStableUtxoSize Constants
defaultConstants
              then -- something moderate 80-120 ^
                Constants -> Int
genTxUtxoIncrement Constants
defaultConstants -- something small 2-5
              else Int
0 -- no change at all
              -- This algorithm has an instability in that if we don't balance
              -- genTxStableUtxoSize and genTxUtxoIncrement correctly the size
              -- of the UTxO gradually shrinks so small we cannot support
              -- generating a transaction. If we get unexplained failures one
              -- might investigate changing these constants.

      -- !_ = occaisionally (length inputs * length ksKeyPairs * length ksMSigScripts) 10000 ("UTxOSize = "++show (Map.size (unUTxO utxo)))

      [Addr (EraCrypto era)]
outputAddrs <-
        forall era.
EraGen era =>
Int
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> Gen [Addr (EraCrypto era)]
genRecipients @era (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn (EraCrypto era)]
inputs forall a. Num a => a -> a -> a
+ Int
n) KeyPairs (EraCrypto era)
ksKeyPairs [(Script era, Script era)]
ksMSigScripts
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
DState era -> [Addr (EraCrypto era)] -> Gen [Addr (EraCrypto era)]
genPtrAddrs (forall era. CertState era -> DState era
certDState CertState era
dpState')

      !()
_ <-
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall t. Val t => t -> Coin
coin Value era
spendingBalance forall a. Ord a => a -> a -> Bool
< forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
          forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
            String
"Negative spending balance " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall t. Val t => t -> Coin
coin Value era
spendingBalance)

      -------------------------------------------------------------------------
      -- Build a Draft Tx and repeatedly add to Delta until all fees are
      -- accounted for.
      -------------------------------------------------------------------------
      let draftFee :: Coin
draftFee = Integer -> Coin
Coin Integer
0
          (Coin
remainderCoin, StrictSeq (TxOut era)
draftOutputs) =
            forall era.
(EraTxOut era, Split (Value era)) =>
Value era
-> [Addr (EraCrypto era)] -> Coin -> (Coin, StrictSeq (TxOut era))
calcOutputsFromBalance @era
              Value era
spendingBalance
              [Addr (EraCrypto era)]
outputAddrs
              Coin
draftFee

      -- Occasionally we have a transaction generated with insufficient inputs
      -- to cover the deposits. In this case we discard the test case.
      let enough :: Coin
enough = forall (t :: * -> *) v. (Foldable t, Val v) => t v -> v
sumVal (forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (TxOut era)
draftOutputs)
      !()
_ <-
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall t. Val t => t -> Coin
coin Value era
spendingBalance forall a. Ord a => a -> a -> Bool
< Coin
enough) forall a b. (a -> b) -> a -> b
$
          forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
            String
"No inputs left. Utxo.hs " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Coin
enough

      (TxBody era
draftTxBody, [Script era]
additionalScripts) <-
        forall era.
EraGen era =>
GenEnv era
-> UTxO era
-> PParams era
-> SlotNo
-> Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> Gen (TxBody era, [Script era])
genEraTxBody
          GenEnv era
ge
          UTxO era
utxo
          PParams era
pparams
          SlotNo
slot
          (forall a. Ord a => [a] -> Set a
Set.fromList [TxIn (EraCrypto era)]
inputs)
          StrictSeq (TxOut era)
draftOutputs
          (forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxCert era]
certs)
          (forall c. Map (RewardAccount c) Coin -> Withdrawals c
Withdrawals (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount (EraCrypto era), Coin)]
wdrls))
          Coin
draftFee
          (forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe Maybe (Update era)
update)
          (forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData @era forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe (TxAuxData era)
metadata)
      let draftTx :: Tx era
draftTx =
            forall era.
EraGen era =>
TxBody era -> TxWits era -> StrictMaybe (TxAuxData era) -> Tx era
constructTx @era
              TxBody era
draftTxBody
              (TxBody era -> TxWits era
mkTxWits' TxBody era
draftTxBody)
              StrictMaybe (TxAuxData era)
metadata
          scripts' :: Map (ScriptHash (EraCrypto era)) (Script era)
scripts' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Script era
s -> (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era Script era
s, Script era
s)) [Script era]
additionalScripts
      -- We add now repeatedly add inputs until the process converges.
      Tx era
tx <-
        forall era.
(EraGen era, Mock (EraCrypto era), EraUTxO era) =>
ScriptInfo era
-> Coin
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Gen (Tx era)
converge
          (forall era.
ScriptSpace era
-> Map (ScriptHash (EraCrypto era)) (TwoPhase3ArgInfo era)
ssHash3 ScriptSpace era
scriptspace, forall era.
ScriptSpace era
-> Map (ScriptHash (EraCrypto era)) (TwoPhase2ArgInfo era)
ssHash2 ScriptSpace era
scriptspace)
          Coin
remainderCoin
          [KeyPair 'Witness (EraCrypto era)]
txWits
          (Map (ScriptHash (EraCrypto era)) (Script era)
scripts forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map (ScriptHash (EraCrypto era)) (Script era)
scripts')
          KeyPairs (EraCrypto era)
ksKeyPairs
          [(Script era, Script era)]
ksMSigScripts
          UTxO era
utxo
          PParams era
pparams
          KeySpace era
keySpace
          Tx era
draftTx
      let txOuts :: StrictSeq (TxOut era)
txOuts = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
      !()
_ <-
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TxOut era
txOut -> forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
txOut forall a. Ord a => a -> a -> Bool
> TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL) StrictSeq (TxOut era)
txOuts) forall a b. (a -> b) -> a -> b
$
          forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
            String
"TxOut value is too small " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show StrictSeq (TxOut era)
txOuts
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx

-- | Collect additional inputs (and witnesses and keys and scripts) to make
-- the transaction balance.
data Delta era = Delta
  { forall era. Delta era -> Coin
dfees :: Coin
  , forall era. Delta era -> Set (TxIn (EraCrypto era))
extraInputs :: Set.Set (TxIn (EraCrypto era))
  , forall era. Delta era -> TxWits era
extraWitnesses :: TxWits era
  , forall era. Delta era -> TxOut era
change :: TxOut era
  , forall era. Delta era -> [KeyPair 'Witness (EraCrypto era)]
deltaVKeys :: [KeyPair 'Witness (EraCrypto era)]
  , forall era. Delta era -> [(Script era, Script era)]
deltaScripts :: [(Script era, Script era)]
  }

instance Show (Delta era) where
  show :: Delta era -> String
show (Delta Coin
fee Set (TxIn (EraCrypto era))
is TxWits era
_wit TxOut era
_change [KeyPair 'Witness (EraCrypto era)]
dvs [(Script era, Script era)]
ds) =
    String
"(Delta"
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Coin
fee
      forall a. [a] -> [a] -> [a]
++ String
" "
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Set a -> Int
Set.size Set (TxIn (EraCrypto era))
is)
      forall a. [a] -> [a] -> [a]
++ String
" wit change "
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [KeyPair 'Witness (EraCrypto era)]
dvs)
      forall a. [a] -> [a] -> [a]
++ String
" "
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Script era, Script era)]
ds)
      forall a. [a] -> [a] -> [a]
++ String
")"

-- | - We need this instance to know when delta has stopped growing. We don't
--  actually need to compare all the fields, because if the extraInputs has not
--  changed then the Scripts and keys will not have changed.
instance
  ( EraTxOut era
  , Eq (TxWits era)
  ) =>
  Eq (Delta era)
  where
  Delta era
a == :: Delta era -> Delta era -> Bool
== Delta era
b =
    forall era. Delta era -> Coin
dfees Delta era
a forall a. Eq a => a -> a -> Bool
== forall era. Delta era -> Coin
dfees Delta era
b
      Bool -> Bool -> Bool
&& forall era. Delta era -> Set (TxIn (EraCrypto era))
extraInputs Delta era
a forall a. Eq a => a -> a -> Bool
== forall era. Delta era -> Set (TxIn (EraCrypto era))
extraInputs Delta era
b
      Bool -> Bool -> Bool
&& forall era. Delta era -> TxWits era
extraWitnesses Delta era
a forall a. Eq a => a -> a -> Bool
== forall era. Delta era -> TxWits era
extraWitnesses Delta era
b
      -- deltaVKeys and deltaScripts equality are implied by extraWitnesses
      -- equality, at least in the use case below.
      Bool -> Bool -> Bool
&& forall era. Delta era -> TxOut era
change Delta era
a forall a. Eq a => a -> a -> Bool
== forall era. Delta era -> TxOut era
change Delta era
b

deltaZero ::
  forall era.
  ( EraTxOut era
  , Monoid (TxWits era)
  ) =>
  Coin ->
  PParams era ->
  Addr (EraCrypto era) ->
  Delta era
deltaZero :: forall era.
(EraTxOut era, Monoid (TxWits era)) =>
Coin -> PParams era -> Addr (EraCrypto era) -> Delta era
deltaZero Coin
initialfee PParams era
pp Addr (EraCrypto era)
addr =
  forall era.
Coin
-> Set (TxIn (EraCrypto era))
-> TxWits era
-> TxOut era
-> [KeyPair 'Witness (EraCrypto era)]
-> [(Script era, Script era)]
-> Delta era
Delta
    (Coin
initialfee forall t. Val t => t -> t -> t
<-> TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL)
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    TxOut era
txOut
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
  where
    txOut :: TxOut era
txOut = forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp (forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
addr forall a. Monoid a => a
mempty)

-- Same function as in cardano-ledger-api. We don't want to depend on the api though,
-- because it will be problematic for dependencies (cardano-ledger-api test suite depends
-- on this package)
setMinCoinTxOut :: EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut :: forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp = TxOut era -> TxOut era
go
  where
    go :: TxOut era -> TxOut era
go TxOut era
txOut =
      let curMinCoin :: Coin
curMinCoin = forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp TxOut era
txOut
          curCoin :: Coin
curCoin = TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL
       in if Coin
curCoin forall a. Eq a => a -> a -> Bool
== Coin
curMinCoin
            then TxOut era
txOut
            else TxOut era -> TxOut era
go (TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
curMinCoin)

encodedLen :: forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen :: forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen t
x = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length (forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerHigh @era) t
x)

-- | Do the work of computing what additioanl inputs we need to 'fix-up' the transaction
-- so that it will balance.
genNextDelta ::
  forall era.
  (EraGen era, Mock (EraCrypto era), EraUTxO era) =>
  ScriptInfo era ->
  UTxO era ->
  PParams era ->
  KeySpace era ->
  Tx era ->
  Int ->
  Delta era ->
  Gen (Delta era)
genNextDelta :: forall era.
(EraGen era, Mock (EraCrypto era), EraUTxO era) =>
ScriptInfo era
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Int
-> Delta era
-> Gen (Delta era)
genNextDelta
  ScriptInfo era
scriptinfo
  UTxO era
utxo
  PParams era
pparams
  KeySpace_
    { Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys :: Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys :: forall era.
KeySpace era
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
    , Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys :: Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys :: forall era.
KeySpace era
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys
    , Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts :: Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts :: forall era.
KeySpace era
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts
    }
  Tx era
tx
  Int
_count -- the counter of the fix loop
  delta :: Delta era
delta@(Delta Coin
dfees Set (TxIn (EraCrypto era))
extraInputs TxWits era
extraWitnesses TxOut era
change [KeyPair 'Witness (EraCrypto era)]
_ [(Script era, Script era)]
extraScripts) =
    let !baseTxFee :: Coin
baseTxFee = forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pparams Tx era
tx UTxO era
utxo
        -- based on the current contents of delta, how much will the fee
        -- increase when we add the delta to the tx?
        draftSize :: Integer
draftSize =
          forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
            [ Integer
11000 :: Integer -- safety net in case the coin or a list prefix rolls over into a
            -- larger encoding, or some other fudge factor occurs. Sometimes we need extra buffer
            -- when minting tokens. 1100 has been empirically determined to make non-failing Txs
            , forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era (forall a. Ord a => a -> a -> a
max Coin
dfees (Integer -> Coin
Coin Integer
0)) forall a. Num a => a -> a -> a
- Integer
1
            , (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TxIn (EraCrypto era)
a Integer
b -> Integer
b forall a. Num a => a -> a -> a
+ forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era TxIn (EraCrypto era)
a) Integer
0 Set (TxIn (EraCrypto era))
extraInputs) forall a. Num a => a -> a -> a
* Integer
2
            , --  inputs end up in collateral as well, so we ^ multiply by 2
              forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era TxOut era
change
            , forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era TxWits era
extraWitnesses
            ]
        deltaScriptCost :: Coin
deltaScriptCost = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Script era, Script era) -> Coin -> Coin
accum (Integer -> Coin
Coin Integer
0) [(Script era, Script era)]
extraScripts
          where
            accum :: (Script era, Script era) -> Coin -> Coin
accum (Script era
s1, Script era
_) Coin
ans = forall era. EraGen era => PParams era -> Script era -> Coin
genEraScriptCost @era PParams era
pparams Script era
s1 forall t. Val t => t -> t -> t
<+> Coin
ans
        deltaFee :: Coin
deltaFee = Integer
draftSize forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
pparams forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall t. Val t => t -> t -> t
<+> Coin
deltaScriptCost
        totalFee :: Coin
totalFee = Coin
baseTxFee forall t. Val t => t -> t -> t
<+> Coin
deltaFee :: Coin
        remainingFee :: Coin
remainingFee = Coin
totalFee forall t. Val t => t -> t -> t
<-> Coin
dfees :: Coin
        changeAmount :: Coin
changeAmount = forall {era}. EraTxOut era => TxOut era -> Coin
getChangeAmount TxOut era
change
        minAda :: Coin
minAda = forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
change
     in if Coin
remainingFee forall a. Ord a => a -> a -> Bool
<= Integer -> Coin
Coin Integer
0 -- we've paid for all the fees
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Delta era
delta -- we're done
          else -- the change covers what we need, so shift Coin from change to dfees.
            if Coin
remainingFee forall a. Ord a => a -> a -> Bool
<= (Coin
changeAmount forall t. Val t => t -> t -> t
<-> Coin
minAda)
              then
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                  Delta era
delta
                    { dfees :: Coin
dfees = Coin
totalFee
                    , change :: TxOut era
change =
                        (Value era -> Value era) -> TxOut era -> TxOut era
deltaChange
                          (forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
inject Coin
remainingFee)
                          TxOut era
change
                    }
              else -- add a new input to cover the fee
                do
                  let txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
                      inputsInUse :: Set (TxIn (EraCrypto era))
inputsInUse = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall a. Semigroup a => a -> a -> a
<> Set (TxIn (EraCrypto era))
extraInputs
                      utxo' :: UTxO era
                      utxo' :: UTxO era
utxo' =
                        -- Remove possible inputs from Utxo, if they already
                        -- appear in inputs.
                        forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
                          forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                            ( \TxIn (EraCrypto era)
k TxOut era
v ->
                                (TxIn (EraCrypto era)
k forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (TxIn (EraCrypto era))
inputsInUse) Bool -> Bool -> Bool
&& forall era. EraGen era => TxOut era -> Bool
genEraGoodTxOut TxOut era
v
                            )
                            -- filter out UTxO entries where the TxOut are not
                            -- appropriate for this Era (i.e. Keylocked in
                            -- AlonzoEra)
                            (forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO UTxO era
utxo)
                  ([TxIn (EraCrypto era)]
inputs, Value era
value, ([KeyPair 'Witness (EraCrypto era)]
vkeyPairs, [(Script era, Script era)]
msigPairs)) <-
                    forall era.
EraTxOut era =>
(Int, Int)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn (EraCrypto era)], Value era,
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genInputs (Int
1, Int
1) Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts UTxO era
utxo'
                  -- It is possible that the Utxo has no possible inputs left, so
                  -- fail. We try and keep this from happening by using feedback:
                  -- adding to the number of ouputs (in the call to genRecipients)
                  -- in genTx above. Adding to the outputs means in the next cycle
                  -- the size of the UTxO will grow. In rare cases, this cannot be avoided
                  -- So we discard this test case. This should happen very rarely.
                  -- If it does happen, It is NOT a test failure, but an inadequacy in the
                  -- testing framework to generate almost-random transactions that always succeed every time.
                  -- Experience suggests that this happens less than 1% of the time, and does not lead to backtracking.
                  !()
_ <- forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxIn (EraCrypto era)]
inputs) forall a b. (a -> b) -> a -> b
$ forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$ String
"NoMoneyleft Utxo.hs " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall t. Val t => t -> Coin
coin Value era
value)
                  let newWits :: TxWits era
newWits =
                        forall era.
(EraGen era, Mock (EraCrypto era)) =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> SafeHash (EraCrypto era) EraIndependentTxBody
-> TxWits era
mkTxWits @era
                          (UTxO era
utxo, TxBody era
txBody, ScriptInfo era
scriptinfo)
                          Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys
                          Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
                          [KeyPair 'Witness (EraCrypto era)]
vkeyPairs
                          (forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
mkScriptWits @era [(Script era, Script era)]
msigPairs forall a. Monoid a => a
mempty)
                          (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody)
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                    Delta era
delta
                      { extraWitnesses :: TxWits era
extraWitnesses = TxWits era
extraWitnesses forall a. Semigroup a => a -> a -> a
<> TxWits era
newWits
                      , extraInputs :: Set (TxIn (EraCrypto era))
extraInputs = Set (TxIn (EraCrypto era))
extraInputs forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList [TxIn (EraCrypto era)]
inputs
                      , change :: TxOut era
change = (Value era -> Value era) -> TxOut era -> TxOut era
deltaChange (forall t. Val t => t -> t -> t
<+> Value era
value) TxOut era
change -- <+> is plus of the Val class
                      , deltaVKeys :: [KeyPair 'Witness (EraCrypto era)]
deltaVKeys = [KeyPair 'Witness (EraCrypto era)]
vkeyPairs forall a. Semigroup a => a -> a -> a
<> forall era. Delta era -> [KeyPair 'Witness (EraCrypto era)]
deltaVKeys Delta era
delta
                      , deltaScripts :: [(Script era, Script era)]
deltaScripts = [(Script era, Script era)]
msigPairs forall a. Semigroup a => a -> a -> a
<> forall era. Delta era -> [(Script era, Script era)]
deltaScripts Delta era
delta
                      }
    where
      deltaChange ::
        (Value era -> Value era) ->
        TxOut era ->
        TxOut era
      deltaChange :: (Value era -> Value era) -> TxOut era -> TxOut era
deltaChange Value era -> Value era
f TxOut era
txOut = TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Value era -> Value era
f
      getChangeAmount :: TxOut era -> Coin
getChangeAmount TxOut era
txOut = TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL

-- calculates fixed point of getNextDelta such that
-- reqFees (tx + delta) = dfees delta
-- start with zero delta
-- genNextDelta repeatedly until genNextDelta delta = delta

genNextDeltaTilFixPoint ::
  forall era.
  ( EraGen era
  , Mock (EraCrypto era)
  , EraUTxO era
  ) =>
  ScriptInfo era ->
  Coin ->
  KeyPairs (EraCrypto era) ->
  [(Script era, Script era)] ->
  UTxO era ->
  PParams era ->
  KeySpace era ->
  Tx era ->
  Gen (Delta era)
genNextDeltaTilFixPoint :: forall era.
(EraGen era, Mock (EraCrypto era), EraUTxO era) =>
ScriptInfo era
-> Coin
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Gen (Delta era)
genNextDeltaTilFixPoint ScriptInfo era
scriptinfo Coin
initialfee KeyPairs (EraCrypto era)
keys [(Script era, Script era)]
scripts UTxO era
utxo PParams era
pparams KeySpace era
keySpace Tx era
tx = do
  [Addr (EraCrypto era)]
addrs <- forall era.
EraGen era =>
Int
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> Gen [Addr (EraCrypto era)]
genRecipients @era Int
1 KeyPairs (EraCrypto era)
keys [(Script era, Script era)]
scripts
  let addr :: Addr (EraCrypto era)
addr = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"genNextDeltaTilFixPoint: empty addrs") forall a. NonEmpty a -> a
NE.head forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Addr (EraCrypto era)]
addrs
  forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix
    Int
0
    (forall era.
(EraGen era, Mock (EraCrypto era), EraUTxO era) =>
ScriptInfo era
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Int
-> Delta era
-> Gen (Delta era)
genNextDelta ScriptInfo era
scriptinfo UTxO era
utxo PParams era
pparams KeySpace era
keySpace Tx era
tx)
    (forall era.
(EraTxOut era, Monoid (TxWits era)) =>
Coin -> PParams era -> Addr (EraCrypto era) -> Delta era
deltaZero Coin
initialfee PParams era
pparams Addr (EraCrypto era)
addr)

applyDelta ::
  forall era.
  ( EraGen era
  , Mock (EraCrypto era)
  ) =>
  UTxO era ->
  ScriptInfo era ->
  PParams era ->
  [KeyPair 'Witness (EraCrypto era)] ->
  Map (ScriptHash (EraCrypto era)) (Script era) ->
  KeySpace era ->
  Tx era ->
  Delta era ->
  Tx era
applyDelta :: forall era.
(EraGen era, Mock (EraCrypto era)) =>
UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> KeySpace era
-> Tx era
-> Delta era
-> Tx era
applyDelta
  UTxO era
utxo
  ScriptInfo era
scriptinfo
  PParams era
pparams
  [KeyPair 'Witness (EraCrypto era)]
neededKeys
  Map (ScriptHash (EraCrypto era)) (Script era)
neededScripts
  KeySpace_ {Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys :: Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys :: forall era.
KeySpace era
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys, Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys :: Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys :: forall era.
KeySpace era
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys}
  Tx era
tx
  (Delta Coin
deltafees Set (TxIn (EraCrypto era))
extraIn TxWits era
_extraWits TxOut era
change [KeyPair 'Witness (EraCrypto era)]
extraKeys [(Script era, Script era)]
extraScripts) =
    -- fix up the witnesses here?
    -- Adds extraInputs, extraWitnesses, and change from delta to tx
    let txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
        oldWitnessSet :: TxWits era
oldWitnessSet =
          forall era.
(EraGen era, Mock (EraCrypto era)) =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> SafeHash (EraCrypto era) EraIndependentTxBody
-> TxWits era
mkTxWits @era
            (UTxO era
utxo, forall era.
EraGen era =>
TxBody era -> Set (TxIn (EraCrypto era)) -> TxBody era
addInputs @era TxBody era
txBody Set (TxIn (EraCrypto era))
extraIn, ScriptInfo era
scriptinfo)
            Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys
            Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
            [KeyPair 'Witness (EraCrypto era)]
kw
            Map (ScriptHash (EraCrypto era)) (Script era)
sw
            (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody)
        body2 :: TxBody era
body2 =
          (forall era.
EraGen era =>
UTxO era
-> PParams era
-> TxWits era
-> TxBody era
-> Coin
-> Set (TxIn (EraCrypto era))
-> TxOut era
-> TxBody era
updateEraTxBody @era)
            UTxO era
utxo
            PParams era
pparams
            TxWits era
oldWitnessSet
            TxBody era
txBody
            Coin
deltafees -- Override the existing fee
            Set (TxIn (EraCrypto era))
extraIn -- Union with existing inputs
            TxOut era
change -- Append to end of the existing outputs
        kw :: [KeyPair 'Witness (EraCrypto era)]
kw = [KeyPair 'Witness (EraCrypto era)]
neededKeys forall a. Semigroup a => a -> a -> a
<> [KeyPair 'Witness (EraCrypto era)]
extraKeys
        sw :: Map (ScriptHash (EraCrypto era)) (Script era)
sw = Map (ScriptHash (EraCrypto era)) (Script era)
neededScripts forall a. Semigroup a => a -> a -> a
<> forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
mkScriptWits @era [(Script era, Script era)]
extraScripts forall a. Monoid a => a
mempty
        newWitnessSet :: TxWits era
newWitnessSet =
          forall era.
(EraGen era, Mock (EraCrypto era)) =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> SafeHash (EraCrypto era) EraIndependentTxBody
-> TxWits era
mkTxWits @era
            (UTxO era
utxo, TxBody era
body2, ScriptInfo era
scriptinfo)
            Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys
            Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
            [KeyPair 'Witness (EraCrypto era)]
kw
            Map (ScriptHash (EraCrypto era)) (Script era)
sw
            (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
body2)
     in forall era.
EraGen era =>
TxBody era -> TxWits era -> StrictMaybe (TxAuxData era) -> Tx era
constructTx @era TxBody era
body2 TxWits era
newWitnessSet (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL)

fix :: (Eq d, Monad m) => Int -> (Int -> d -> m d) -> d -> m d
fix :: forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix Int
n Int -> d -> m d
f d
d = do d
d1 <- Int -> d -> m d
f Int
n d
d; if d
d1 forall a. Eq a => a -> a -> Bool
== d
d then forall (f :: * -> *) a. Applicative f => a -> f a
pure d
d else forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix (Int
n forall a. Num a => a -> a -> a
+ Int
1) Int -> d -> m d
f d
d1

converge ::
  forall era.
  (EraGen era, Mock (EraCrypto era), EraUTxO era) =>
  ScriptInfo era ->
  Coin ->
  [KeyPair 'Witness (EraCrypto era)] ->
  Map (ScriptHash (EraCrypto era)) (Script era) ->
  KeyPairs (EraCrypto era) ->
  [(Script era, Script era)] ->
  UTxO era ->
  PParams era ->
  KeySpace era ->
  Tx era ->
  Gen (Tx era)
converge :: forall era.
(EraGen era, Mock (EraCrypto era), EraUTxO era) =>
ScriptInfo era
-> Coin
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Gen (Tx era)
converge
  ScriptInfo era
scriptinfo
  Coin
initialfee
  [KeyPair 'Witness (EraCrypto era)]
neededKeys
  Map (ScriptHash (EraCrypto era)) (Script era)
neededScripts
  KeyPairs (EraCrypto era)
keys
  [(Script era, Script era)]
scripts
  UTxO era
utxo
  PParams era
pparams
  KeySpace era
keySpace
  Tx era
tx = do
    Delta era
delta <- forall era.
(EraGen era, Mock (EraCrypto era), EraUTxO era) =>
ScriptInfo era
-> Coin
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Gen (Delta era)
genNextDeltaTilFixPoint ScriptInfo era
scriptinfo Coin
initialfee KeyPairs (EraCrypto era)
keys [(Script era, Script era)]
scripts UTxO era
utxo PParams era
pparams KeySpace era
keySpace Tx era
tx
    forall era.
EraGen era =>
UTxO era -> PParams era -> Tx era -> Gen (Tx era)
genEraDone @era
      UTxO era
utxo
      PParams era
pparams
      (forall era.
(EraGen era, Mock (EraCrypto era)) =>
UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> KeySpace era
-> Tx era
-> Delta era
-> Tx era
applyDelta UTxO era
utxo ScriptInfo era
scriptinfo PParams era
pparams [KeyPair 'Witness (EraCrypto era)]
neededKeys Map (ScriptHash (EraCrypto era)) (Script era)
neededScripts KeySpace era
keySpace Tx era
tx Delta era
delta)

-- | Return up to /k/ random elements from /items/
-- (instead of the less efficient /take k <$> QC.shuffle items/)
ruffle :: Int -> [a] -> Gen [a]
ruffle :: forall a. Int -> [a] -> Gen [a]
ruffle Int
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
ruffle Int
k [a]
items = do
  ([Int]
indices, IntSet
_) <- Int -> (Int, Int) -> Gen ([Int], IntSet)
genIndices Int
k (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector a
itemsV forall a. Num a => a -> a -> a
- Int
1)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Vector a
itemsV forall a. Vector a -> Int -> a
V.!) [Int]
indices
  where
    itemsV :: Vector a
itemsV = forall a. [a] -> Vector a
V.fromList [a]
items

-- | Generate @k@ number of unique `Int`s in the supplied range.
genIndices :: Int -> (Int, Int) -> Gen ([Int], IntSet.IntSet)
genIndices :: Int -> (Int, Int) -> Gen ([Int], IntSet)
genIndices Int
k (Int
l', Int
u')
  | Int
k forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
u forall a. Num a => a -> a -> a
- Int
l forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
< Int
k =
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
        String
"Cannot generate "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k
          forall a. [a] -> [a] -> [a]
++ String
" indices in the range ["
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l
          forall a. [a] -> [a] -> [a]
++ String
", "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
u
          forall a. [a] -> [a] -> [a]
++ String
"]"
  | Int
u forall a. Num a => a -> a -> a
- Int
l forall a. Ord a => a -> a -> Bool
< Int
k forall a. Num a => a -> a -> a
* Int
2 = do
      [Int]
xs <- forall a. Int -> [a] -> [a]
take Int
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen [a]
QC.shuffle [Int
l .. Int
u]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
xs, [Int] -> IntSet
IntSet.fromList [Int]
xs)
  | Bool
otherwise = Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go Int
k [] forall a. Monoid a => a
mempty
  where
    (Int
l, Int
u) =
      if Int
l' forall a. Ord a => a -> a -> Bool
<= Int
u'
        then (Int
l', Int
u')
        else (Int
u', Int
l')
    go :: Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go Int
n ![Int]
res !IntSet
acc
      | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
res, IntSet
acc)
      | Bool
otherwise = do
          Int
i <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
l, Int
u)
          if Int -> IntSet -> Bool
IntSet.member Int
i IntSet
acc
            then Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go Int
n [Int]
res IntSet
acc
            else Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go (Int
n forall a. Num a => a -> a -> a
- Int
1) (Int
i forall a. a -> [a] -> [a]
: [Int]
res) forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IntSet.insert Int
i IntSet
acc

-- | Select @n@ random key value pairs from the supplied map. Order of keys with
-- respect to each other will also be random, i.e. not sorted.
pickRandomFromMap :: Int -> Map.Map k t -> Gen [(k, t)]
pickRandomFromMap :: forall k t. Int -> Map k t -> Gen [(k, t)]
pickRandomFromMap Int
n Map k t
initMap = forall g (m :: * -> *) f k v.
(StatefulGen g m, Monoid f) =>
(k -> v -> f -> f) -> Maybe Int -> Map k v -> g -> m f
uniformSubMapElems (\k
k t
v -> ((k
k, t
v) forall a. a -> [a] -> [a]
:)) (forall a. a -> Maybe a
Just Int
n) Map k t
initMap QC
QC

mkScriptWits ::
  forall era.
  EraGen era =>
  [(Script era, Script era)] ->
  [(Script era, Script era)] ->
  Map (ScriptHash (EraCrypto era)) (Script era)
mkScriptWits :: forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
mkScriptWits [(Script era, Script era)]
payScripts [(Script era, Script era)]
stakeScripts =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    ((Script era, Script era)
-> (ScriptHash (EraCrypto era), Script era)
hashPayScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
payScripts)
      forall a. [a] -> [a] -> [a]
++ ((Script era, Script era)
-> (ScriptHash (EraCrypto era), Script era)
hashStakeScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
stakeScripts)
  where
    hashPayScript ::
      (Script era, Script era) ->
      (ScriptHash (EraCrypto era), Script era)
    hashPayScript :: (Script era, Script era)
-> (ScriptHash (EraCrypto era), Script era)
hashPayScript (Script era
payScript, Script era
_) =
      (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era Script era
payScript, Script era
payScript)

    hashStakeScript ::
      (Script era, Script era) ->
      (ScriptHash (EraCrypto era), Script era)
    hashStakeScript :: (Script era, Script era)
-> (ScriptHash (EraCrypto era), Script era)
hashStakeScript (Script era
_, Script era
sScript) =
      (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era Script era
sScript, Script era
sScript)

mkTxWits ::
  forall era.
  (EraGen era, Mock (EraCrypto era)) =>
  (UTxO era, TxBody era, ScriptInfo era) ->
  Map (KeyHash 'Payment (EraCrypto era)) (KeyPair 'Payment (EraCrypto era)) ->
  Map (KeyHash 'Staking (EraCrypto era)) (KeyPair 'Staking (EraCrypto era)) ->
  [KeyPair 'Witness (EraCrypto era)] ->
  Map (ScriptHash (EraCrypto era)) (Script era) ->
  SafeHash (EraCrypto era) EraIndependentTxBody ->
  TxWits era
mkTxWits :: forall era.
(EraGen era, Mock (EraCrypto era)) =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> [KeyPair 'Witness (EraCrypto era)]
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> SafeHash (EraCrypto era) EraIndependentTxBody
-> TxWits era
mkTxWits
  (UTxO era
utxo, TxBody era
txbody, ScriptInfo era
scriptinfo)
  Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
indexedPaymentKeys
  Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
indexedStakingKeys
  [KeyPair 'Witness (EraCrypto era)]
awits
  Map (ScriptHash (EraCrypto era)) (Script era)
msigs
  SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash =
    forall era.
EraGen era =>
(UTxO era, TxBody era, ScriptInfo era)
-> Set (WitVKey 'Witness (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> TxWits era
genEraTxWits @era
      (UTxO era
utxo, TxBody era
txbody, ScriptInfo era
scriptinfo)
      ( forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash [KeyPair 'Witness (EraCrypto era)]
awits
          forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash c EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> Map (KeyHash kr c) (KeyPair kr c)
-> Set (KeyHash kr c)
-> Set (WitVKey 'Witness c)
makeWitnessesFromScriptKeys
            SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash
            ( Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
indexedPaymentKeysAsWitnesses
                forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
indexedStakingKeysAsWitnesses
            )
            Set (KeyHash 'Witness (EraCrypto era))
msigSignatures
      )
      Map (ScriptHash (EraCrypto era)) (Script era)
msigs
    where
      indexedPaymentKeysAsWitnesses :: Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
indexedPaymentKeysAsWitnesses =
        forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(KeyHash 'Payment (EraCrypto era)
a, KeyPair 'Payment (EraCrypto era)
b) -> (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash 'Payment (EraCrypto era)
a, forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment (EraCrypto era)
b))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
          forall a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
indexedPaymentKeys
      indexedStakingKeysAsWitnesses :: Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
indexedStakingKeysAsWitnesses =
        forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(KeyHash 'Staking (EraCrypto era)
a, KeyPair 'Staking (EraCrypto era)
b) -> (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash 'Staking (EraCrypto era)
a, forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Staking (EraCrypto era)
b))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
          forall a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
indexedStakingKeys
      keysLists :: [[KeyHash 'Witness (EraCrypto era)]]
keysLists = forall a b. (a -> b) -> [a] -> [b]
map (forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness (EraCrypto era)]
scriptKeyCombination (forall {k} (t :: k). Proxy t
Proxy @era)) (forall k a. Map k a -> [a]
Map.elems Map (ScriptHash (EraCrypto era)) (Script era)
msigs)
      msigSignatures :: Set (KeyHash 'Witness (EraCrypto era))
msigSignatures = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall a. Ord a => Set a -> Set a -> Set a
Set.union forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> Set a
Set.fromList [[KeyHash 'Witness (EraCrypto era)]]
keysLists

-- | Distribute the sum of `balance_` and `fee` over the addresses, return the
-- sum of `fee` and the remainder of the equal distribution and the list ouf
-- transaction outputs that cover the balance and fees.
--
-- The idea is to have an specified spending balance and fees that must be paid
-- by the selected addresses.
-- TODO need right splitting of v!
calcOutputsFromBalance ::
  forall era.
  ( EraTxOut era
  , Split (Value era)
  ) =>
  Value era ->
  [Addr (EraCrypto era)] ->
  Coin ->
  (Coin, StrictSeq (TxOut era))
calcOutputsFromBalance :: forall era.
(EraTxOut era, Split (Value era)) =>
Value era
-> [Addr (EraCrypto era)] -> Coin -> (Coin, StrictSeq (TxOut era))
calcOutputsFromBalance Value era
balance_ [Addr (EraCrypto era)]
addrs Coin
fee =
  ( Coin
fee forall t. Val t => t -> t -> t
<+> Coin
splitCoinRem
  , forall a. [a] -> StrictSeq a
StrictSeq.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut [Addr (EraCrypto era)]
addrs [Value era]
amountPerOutput
  )
  where
    -- split the available balance into equal portions (one for each address),
    -- if there is a remainder, then add it to the fee.
    balanceAfterFee :: Value era
balanceAfterFee = Value era
balance_ forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
inject Coin
fee
    ([Value era]
amountPerOutput, Coin
splitCoinRem) =
      forall v. Split v => v -> Integer -> ([v], Coin)
vsplit Value era
balanceAfterFee (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr (EraCrypto era)]
addrs)

-- | Select unspent output(s) to serve as inputs for a new transaction
--
-- Returns the inputs, paired with the KeyPair or multi-sig script required to
-- witness the spending of the input.
-- Also returns the total spendable balance.

-- NOTE: this function needs access to the keys and multi-sig scripts that the
-- given UTxO originated from (in order to produce the appropriate witnesses to
-- spend these outputs). If this is not the case, `findPayKeyPairAddr` /
-- `findPayScriptFromAddr` will fail by not finding the matching keys or scripts.
genInputs ::
  forall era.
  EraTxOut era =>
  (Int, Int) ->
  Map (KeyHash 'Payment (EraCrypto era)) (KeyPair 'Payment (EraCrypto era)) ->
  Map (ScriptHash (EraCrypto era)) (Script era, Script era) ->
  UTxO era ->
  Gen
    ( [TxIn (EraCrypto era)]
    , Value era
    , ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)])
    )
genInputs :: forall era.
EraTxOut era =>
(Int, Int)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn (EraCrypto era)], Value era,
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genInputs (Int
minNumGenInputs, Int
maxNumGenInputs) Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
keyHashMap Map (ScriptHash (EraCrypto era)) (Script era, Script era)
payScriptMap (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo) = do
  Int
numInputs <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
minNumGenInputs, Int
maxNumGenInputs)
  [(TxIn (EraCrypto era), TxOut era)]
selectedUtxo <- forall k t. Int -> Map k t -> Gen [(k, t)]
pickRandomFromMap Int
numInputs Map (TxIn (EraCrypto era)) (TxOut era)
utxo
  let ([TxIn (EraCrypto era)]
inputs, [Either
   (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)]
witnesses) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut era
-> Either
     (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)
witnessedInput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn (EraCrypto era), TxOut era)]
selectedUtxo)
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [TxIn (EraCrypto era)]
inputs
    , forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue @era (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn (EraCrypto era), TxOut era)]
selectedUtxo)
    , forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either
   (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)]
witnesses
    )
  where
    witnessedInput :: TxOut era
-> Either
     (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)
witnessedInput TxOut era
output =
      case TxOut era
output forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL of
        addr :: Addr (EraCrypto era)
addr@(Addr Network
_ (KeyHashObj KeyHash 'Payment (EraCrypto era)
_) StakeReference (EraCrypto era)
_) ->
          forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall era.
Addr (EraCrypto era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> KeyPair 'Payment (EraCrypto era)
findPayKeyPairAddr @era Addr (EraCrypto era)
addr Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
keyHashMap
        addr :: Addr (EraCrypto era)
addr@(Addr Network
_ (ScriptHashObj ScriptHash (EraCrypto era)
_) StakeReference (EraCrypto era)
_) ->
          forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall era.
Addr (EraCrypto era)
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromAddr @era Addr (EraCrypto era)
addr Map (ScriptHash (EraCrypto era)) (Script era, Script era)
payScriptMap
        Addr (EraCrypto era)
_ -> forall a. HasCallStack => String -> a
error String
"unsupported address"

-- | Select a subset of the reward accounts to use for reward withdrawals.
genWithdrawals ::
  forall era.
  Constants ->
  Map (ScriptHash (EraCrypto era)) (Script era, Script era) ->
  Map (KeyHash 'Staking (EraCrypto era)) (KeyPair 'Staking (EraCrypto era)) ->
  Map (Credential 'Staking (EraCrypto era)) Coin ->
  Gen
    ( [(RewardAccount (EraCrypto era), Coin)]
    , ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)])
    )
genWithdrawals :: forall era.
Constants
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Gen
     ([(RewardAccount (EraCrypto era), Coin)],
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genWithdrawals
  Constants
    { Int
frequencyNoWithdrawals :: Constants -> Int
frequencyNoWithdrawals :: Int
frequencyNoWithdrawals
    , Int
frequencyAFewWithdrawals :: Constants -> Int
frequencyAFewWithdrawals :: Int
frequencyAFewWithdrawals
    , Int
frequencyPotentiallyManyWithdrawals :: Constants -> Int
frequencyPotentiallyManyWithdrawals :: Int
frequencyPotentiallyManyWithdrawals
    , Int
maxAFewWithdrawals :: Constants -> Int
maxAFewWithdrawals :: Int
maxAFewWithdrawals
    }
  Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts
  Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
  Map (Credential 'Staking (EraCrypto era)) Coin
withdrawals = do
    ([(RewardAccount (EraCrypto era), Coin)]
a, ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)])
b) <-
      forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
        [
          ( Int
frequencyNoWithdrawals
          , forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], ([], []))
          )
        ,
          ( Int
frequencyAFewWithdrawals
          , [(Credential 'Staking (EraCrypto era), Coin)]
-> Gen
     ([(RewardAccount (EraCrypto era), Coin)],
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genWrdls (forall a. Int -> [a] -> [a]
take Int
maxAFewWithdrawals forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking (EraCrypto era)) Coin
withdrawals)
          )
        ,
          ( Int
frequencyPotentiallyManyWithdrawals
          , [(Credential 'Staking (EraCrypto era), Coin)]
-> Gen
     ([(RewardAccount (EraCrypto era), Coin)],
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genWrdls (forall k a. Map k a -> [(k, a)]
Map.toList Map (Credential 'Staking (EraCrypto era)) Coin
withdrawals)
          )
        ]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(RewardAccount (EraCrypto era), Coin)]
a, ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)])
b)
    where
      toRewardAccount :: (Credential 'Staking c, b) -> (RewardAccount c, b)
toRewardAccount (Credential 'Staking c
rwd, b
coinx) = (forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet Credential 'Staking c
rwd, b
coinx)
      genWrdls :: [(Credential 'Staking (EraCrypto era), Coin)]
-> Gen
     ([(RewardAccount (EraCrypto era), Coin)],
      ([KeyPair 'Witness (EraCrypto era)], [(Script era, Script era)]))
genWrdls [(Credential 'Staking (EraCrypto era), Coin)]
withdrawals_ = do
        [(RewardAccount (EraCrypto era), Coin)]
selectedWrdls <- forall a b. (a -> b) -> [a] -> [b]
map forall {c} {b}. (Credential 'Staking c, b) -> (RewardAccount c, b)
toRewardAccount forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen [a]
QC.sublistOf [(Credential 'Staking (EraCrypto era), Coin)]
withdrawals_
        let txwits :: [Either
   (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)]
txwits =
              forall era.
Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> Credential 'Staking (EraCrypto era)
-> Either
     (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)
mkWithdrawalsWits @era Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. RewardAccount c -> Credential 'Staking c
raCredential
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RewardAccount (EraCrypto era), Coin)]
selectedWrdls
        forall (m :: * -> *) a. Monad m => a -> m a
return ([(RewardAccount (EraCrypto era), Coin)]
selectedWrdls, forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either
   (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)]
txwits)

-- | Collect witnesses needed for reward withdrawals.
mkWithdrawalsWits ::
  forall era.
  Map (ScriptHash (EraCrypto era)) (Script era, Script era) ->
  Map (KeyHash 'Staking (EraCrypto era)) (KeyPair 'Staking (EraCrypto era)) ->
  Credential 'Staking (EraCrypto era) ->
  Either (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)
mkWithdrawalsWits :: forall era.
Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
-> Credential 'Staking (EraCrypto era)
-> Either
     (KeyPair 'Witness (EraCrypto era)) (Script era, Script era)
mkWithdrawalsWits Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByStakeHash Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
_ c :: Credential 'Staking (EraCrypto era)
c@(ScriptHashObj ScriptHash (EraCrypto era)
_) =
  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
    forall era.
Credential 'Witness (EraCrypto era)
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> (Script era, Script era)
findStakeScriptFromCred @era (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness Credential 'Staking (EraCrypto era)
c) Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByStakeHash
mkWithdrawalsWits Map (ScriptHash (EraCrypto era)) (Script era, Script era)
_ Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
keyHashMap c :: Credential 'Staking (EraCrypto era)
c@(KeyHashObj KeyHash 'Staking (EraCrypto era)
_) =
  forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
    forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$
      forall era (kr :: KeyRole).
Credential kr (EraCrypto era)
-> Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era))
-> KeyPair kr (EraCrypto era)
findPayKeyPairCred @era Credential 'Staking (EraCrypto era)
c Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
keyHashMap

-- | Select recipient addresses that will serve as output targets for a new
-- transaction.
genRecipients ::
  forall era.
  EraGen era =>
  Int ->
  KeyPairs (EraCrypto era) ->
  [(Script era, Script era)] ->
  Gen [Addr (EraCrypto era)]
genRecipients :: forall era.
EraGen era =>
Int
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> Gen [Addr (EraCrypto era)]
genRecipients Int
nRecipients' KeyPairs (EraCrypto era)
keys [(Script era, Script era)]
scripts = do
  Int
nRecipients <-
    forall a. Ord a => a -> a -> a
max Int
1
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
        [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nRecipients' forall a. Num a => a -> a -> a
- Int
1)) -- contract size of UTxO
        , (Int
2, forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
nRecipients') -- keep size
        , (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nRecipients' forall a. Num a => a -> a -> a
+ Int
1)) -- expand size of UTxO
        ]

  -- We want to choose more Keys than Scripts by a factor of 2 or more.
  Int
nScripts <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int
nRecipients forall a. Num a => a -> a -> a
* Int
2 forall a. Integral a => a -> a -> a
`div` Int
3) -- Average is about nRecipients / 3
  let nKeys :: Int
nKeys = Int
nRecipients forall a. Num a => a -> a -> a
- Int
nScripts

  KeyPairs (EraCrypto era)
recipientKeys <- forall a. Int -> [a] -> Gen [a]
ruffle Int
nKeys KeyPairs (EraCrypto era)
keys
  [(Script era, Script era)]
recipientScripts <- forall a. Int -> [a] -> Gen [a]
ruffle Int
nScripts [(Script era, Script era)]
scripts

  let payKeys :: [Credential 'Payment (EraCrypto era)]
payKeys = forall c (kr :: KeyRole).
Crypto c =>
KeyPair kr c -> Credential kr c
mkCred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs (EraCrypto era)
recipientKeys
      stakeKeys :: [Credential 'Staking (EraCrypto era)]
stakeKeys = forall c (kr :: KeyRole).
Crypto c =>
KeyPair kr c -> Credential kr c
mkCred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs (EraCrypto era)
recipientKeys
      payScripts :: [Credential 'Payment (EraCrypto era)]
payScripts = forall (kr :: KeyRole). Script era -> Credential kr (EraCrypto era)
scriptToCred' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
recipientScripts
      stakeScripts :: [Credential 'Staking (EraCrypto era)]
stakeScripts = forall (kr :: KeyRole). Script era -> Credential kr (EraCrypto era)
scriptToCred' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
recipientScripts

  -- zip keys and scripts together as base addresses
  let payCreds :: [Credential 'Payment (EraCrypto era)]
payCreds = [Credential 'Payment (EraCrypto era)]
payKeys forall a. [a] -> [a] -> [a]
++ [Credential 'Payment (EraCrypto era)]
payScripts
      stakeCreds :: [Credential 'Staking (EraCrypto era)]
stakeCreds = [Credential 'Staking (EraCrypto era)]
stakeKeys forall a. [a] -> [a] -> [a]
++ [Credential 'Staking (EraCrypto era)]
stakeScripts
  let stakeCreds' :: [StakeReference (EraCrypto era)]
stakeCreds' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. StakeCredential c -> StakeReference c
StakeRefBase [Credential 'Staking (EraCrypto era)]
stakeCreds

  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet) [Credential 'Payment (EraCrypto era)]
payCreds [StakeReference (EraCrypto era)]
stakeCreds')
  where
    scriptToCred' :: Script era -> Credential kr (EraCrypto era)
    scriptToCred' :: forall (kr :: KeyRole). Script era -> Credential kr (EraCrypto era)
scriptToCred' = forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era

genPtrAddrs :: DState era -> [Addr (EraCrypto era)] -> Gen [Addr (EraCrypto era)]
genPtrAddrs :: forall era.
DState era -> [Addr (EraCrypto era)] -> Gen [Addr (EraCrypto era)]
genPtrAddrs DState era
ds [Addr (EraCrypto era)]
addrs = do
  let pointers :: Map Ptr (Credential 'Staking (EraCrypto era))
pointers = forall era.
DState era -> Map Ptr (Credential 'Staking (EraCrypto era))
ptrsMap DState era
ds
  Int
n <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, forall a. Ord a => a -> a -> a
min (forall k a. Map k a -> Int
Map.size Map Ptr (Credential 'Staking (EraCrypto era))
pointers) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr (EraCrypto era)]
addrs))
  [Ptr]
pointerList <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k t. Int -> Map k t -> Gen [(k, t)]
pickRandomFromMap Int
n Map Ptr (Credential 'Staking (EraCrypto era))
pointers

  let addrs' :: [Addr (EraCrypto era)]
addrs' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {c}. Addr c -> Ptr -> Addr c
baseAddrToPtrAddr (forall a. Int -> [a] -> [a]
take Int
n [Addr (EraCrypto era)]
addrs) [Ptr]
pointerList

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Addr (EraCrypto era)]
addrs' forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop Int
n [Addr (EraCrypto era)]
addrs)
  where
    baseAddrToPtrAddr :: Addr c -> Ptr -> Addr c
baseAddrToPtrAddr Addr c
a Ptr
p = case Addr c
a of
      Addr Network
n PaymentCredential c
pay StakeReference c
_ -> forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
n PaymentCredential c
pay (forall c. Ptr -> StakeReference c
StakeRefPtr Ptr
p)
      Addr c
_ -> Addr c
a