{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE DerivingVia               #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE UndecidableInstances      #-}
{-# LANGUAGE ViewPatterns              #-}

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Ledger.Constraints.OffChain(
    -- * Lookups
    ScriptLookups(..)
    , typedValidatorLookups
    , generalise
    , unspentOutputs
    , mintingPolicy
    , plutusV1MintingPolicy
    , plutusV2MintingPolicy
    , otherScript
    , plutusV1OtherScript
    , plutusV2OtherScript
    , otherData
    , ownPaymentPubKeyHash
    , ownStakingCredential
    , paymentPubKey
    , paymentPubKeyHash
    -- * Constraints resolution
    , SomeLookupsAndConstraints(..)
    , UnbalancedTx(..)
    , unBalancedTxTx
    , cardanoTx
    , tx
    , requiredSignatories
    , utxoIndex
    , emptyUnbalancedTx
    , adjustUnbalancedTx
    , adjustTxOut
    , MkTxError(..)
    , _TypeCheckFailed
    , _ToCardanoError
    , _TxOutRefNotFound
    , _TxOutRefWrongType
    , _TxOutRefNoReferenceScript
    , _DatumNotFound
    , _DeclaredInputMismatch
    , _MintingPolicyNotFound
    , _ScriptHashNotFound
    , _TypedValidatorMissing
    , _DatumWrongHash
    , _CannotSatisfyAny
    , _NoMatchingOutputFound
    , _MultipleMatchingOutputsFound
    , mkTx
    , mkTxWithParams
    , mkSomeTx
    -- * Internals exposed for testing
    , ValueSpentBalances(..)
    , provided
    , required
    , missingValueSpent
    , ConstraintProcessingState(..)
    , unbalancedTx
    , valueSpentInputs
    , valueSpentOutputs
    , paramsL
    , processConstraintFun
    , addOwnInput
    , addOwnOutput
    , updateUtxoIndex
    , lookupTxOutRef
    , lookupMintingPolicy
    , lookupScript
    , lookupScriptAsReferenceScript
    , prepareConstraints
    , resolveScriptTxOut
    , resolveScriptTxOutValidator
    , resolveScriptTxOutDatumAndValue
    , DatumWithOrigin(..)
    , datumWitness
    , checkValueSpent
    ) where

import Cardano.Api qualified as C
import Cardano.Node.Emulator.Params (PParams, Params (pNetworkId, pSlotConfig))
import Cardano.Node.Emulator.TimeSlot (posixTimeRangeToContainedSlotRange)
import Control.Lens (_2, alaf, at, makeClassyPrisms, makeLensesFor, preview, uses, view, (%=), (.=), (<>=), (^.), (^?))
import Control.Lens.Extras (is)
import Control.Monad (forM_, guard)
import Control.Monad.Except (MonadError (catchError, throwError), runExcept, unless)
import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks)
import Control.Monad.State (MonadState (get, put), execStateT, gets)
import Data.Aeson (FromJSON, ToJSON)
import Data.Default (def)
import Data.Foldable (traverse_)
import Data.Functor.Compose (Compose (Compose))
import Data.List qualified as List
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (mapMaybe)
import Data.OpenApi.Schema qualified as OpenApi
import Data.Semigroup (First (First, getFirst))
import Data.Set (Set)
import Data.Set qualified as Set
import GHC.Generics (Generic)
import Ledger (Redeemer (Redeemer), decoratedTxOutReferenceScript)
import Ledger.Ada qualified as Ada
import Ledger.Address (Address, PaymentPubKey (PaymentPubKey), PaymentPubKeyHash (PaymentPubKeyHash))
import Ledger.Constraints.TxConstraints (ScriptInputConstraint (ScriptInputConstraint, icRedeemer, icTxOutRef),
                                         ScriptOutputConstraint (ScriptOutputConstraint, ocDatum, ocReferenceScriptHash, ocValue),
                                         TxConstraint (MustBeSignedBy, MustIncludeDatumInTx, MustIncludeDatumInTxWithHash, MustMintValue, MustPayToAddress, MustProduceAtLeast, MustReferenceOutput, MustSatisfyAnyOf, MustSpendAtLeast, MustSpendPubKeyOutput, MustSpendScriptOutput, MustUseOutputAsCollateral, MustValidateInTimeRange),
                                         TxConstraintFun (MustSpendScriptOutputWithMatchingDatumAndValue),
                                         TxConstraintFuns (TxConstraintFuns),
                                         TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs),
                                         TxOutDatum (TxOutDatumHash, TxOutDatumInTx, TxOutDatumInline))
import Ledger.Constraints.ValidityInterval (toPlutusInterval)
import Ledger.Crypto (pubKeyHash)
import Ledger.Index (adjustTxOut)
import Ledger.Orphans ()
import Ledger.Tx (DecoratedTxOut, Language (PlutusV1, PlutusV2), ReferenceScript, TxOut (TxOut), TxOutRef,
                  Versioned (Versioned))
import Ledger.Tx qualified as Tx
import Ledger.Tx.CardanoAPI qualified as C
import Ledger.Typed.Scripts (Any, ConnectionError (UnknownRef), TypedValidator (tvValidator, tvValidatorHash),
                             ValidatorTypes (DatumType, RedeemerType), validatorAddress)
import Plutus.Script.Utils.Scripts qualified as P
import Plutus.Script.Utils.V2.Typed.Scripts qualified as Typed
import Plutus.V1.Ledger.Api (Datum (Datum), DatumHash, StakingCredential, Validator (getValidator), Value,
                             getMintingPolicy)
import Plutus.V1.Ledger.Scripts (MintingPolicy (MintingPolicy), MintingPolicyHash (MintingPolicyHash), Script,
                                 ScriptHash (ScriptHash), Validator (Validator), ValidatorHash (ValidatorHash))
import Plutus.V1.Ledger.Value qualified as Value
import Plutus.V2.Ledger.Tx qualified as PV2
import PlutusTx (FromData, ToData (toBuiltinData))
import PlutusTx.Lattice (JoinSemiLattice ((\/)), MeetSemiLattice ((/\)))
import PlutusTx.Numeric qualified as N
import Prettyprinter (Pretty (pretty), colon, hang, vsep, (<+>))

data ScriptLookups a =
    ScriptLookups
        { ScriptLookups a -> Map TxOutRef DecoratedTxOut
slTxOutputs            :: Map TxOutRef DecoratedTxOut
        -- ^ Unspent outputs that the script may want to spend
        , ScriptLookups a -> Map ScriptHash (Versioned Script)
slOtherScripts         :: Map ScriptHash (Versioned Script)
        -- ^ Scripts other than "our script"
        , ScriptLookups a -> Map DatumHash Datum
slOtherData            :: Map DatumHash Datum
        -- ^ Datums that we might need
        , ScriptLookups a -> Set PaymentPubKeyHash
slPaymentPubKeyHashes  :: Set PaymentPubKeyHash
        -- ^ Public keys that we might need
        , ScriptLookups a -> Maybe (TypedValidator a)
slTypedValidator       :: Maybe (TypedValidator a)
        -- ^ The script instance with the typed validator hash & actual compiled program
        , ScriptLookups a -> Maybe PaymentPubKeyHash
slOwnPaymentPubKeyHash :: Maybe PaymentPubKeyHash
        -- ^ The contract's payment public key hash, used for depositing tokens etc.
        , ScriptLookups a -> Maybe StakingCredential
slOwnStakingCredential :: Maybe StakingCredential
        -- ^ The contract's staking credentials (optional)
        } deriving stock (Int -> ScriptLookups a -> ShowS
[ScriptLookups a] -> ShowS
ScriptLookups a -> String
(Int -> ScriptLookups a -> ShowS)
-> (ScriptLookups a -> String)
-> ([ScriptLookups a] -> ShowS)
-> Show (ScriptLookups a)
forall a. Int -> ScriptLookups a -> ShowS
forall a. [ScriptLookups a] -> ShowS
forall a. ScriptLookups a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptLookups a] -> ShowS
$cshowList :: forall a. [ScriptLookups a] -> ShowS
show :: ScriptLookups a -> String
$cshow :: forall a. ScriptLookups a -> String
showsPrec :: Int -> ScriptLookups a -> ShowS
$cshowsPrec :: forall a. Int -> ScriptLookups a -> ShowS
Show, (forall x. ScriptLookups a -> Rep (ScriptLookups a) x)
-> (forall x. Rep (ScriptLookups a) x -> ScriptLookups a)
-> Generic (ScriptLookups a)
forall x. Rep (ScriptLookups a) x -> ScriptLookups a
forall x. ScriptLookups a -> Rep (ScriptLookups a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ScriptLookups a) x -> ScriptLookups a
forall a x. ScriptLookups a -> Rep (ScriptLookups a) x
$cto :: forall a x. Rep (ScriptLookups a) x -> ScriptLookups a
$cfrom :: forall a x. ScriptLookups a -> Rep (ScriptLookups a) x
Generic)
          deriving anyclass ([ScriptLookups a] -> Encoding
[ScriptLookups a] -> Value
ScriptLookups a -> Encoding
ScriptLookups a -> Value
(ScriptLookups a -> Value)
-> (ScriptLookups a -> Encoding)
-> ([ScriptLookups a] -> Value)
-> ([ScriptLookups a] -> Encoding)
-> ToJSON (ScriptLookups a)
forall a. [ScriptLookups a] -> Encoding
forall a. [ScriptLookups a] -> Value
forall a. ScriptLookups a -> Encoding
forall a. ScriptLookups a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ScriptLookups a] -> Encoding
$ctoEncodingList :: forall a. [ScriptLookups a] -> Encoding
toJSONList :: [ScriptLookups a] -> Value
$ctoJSONList :: forall a. [ScriptLookups a] -> Value
toEncoding :: ScriptLookups a -> Encoding
$ctoEncoding :: forall a. ScriptLookups a -> Encoding
toJSON :: ScriptLookups a -> Value
$ctoJSON :: forall a. ScriptLookups a -> Value
ToJSON, Value -> Parser [ScriptLookups a]
Value -> Parser (ScriptLookups a)
(Value -> Parser (ScriptLookups a))
-> (Value -> Parser [ScriptLookups a])
-> FromJSON (ScriptLookups a)
forall a. Value -> Parser [ScriptLookups a]
forall a. Value -> Parser (ScriptLookups a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ScriptLookups a]
$cparseJSONList :: forall a. Value -> Parser [ScriptLookups a]
parseJSON :: Value -> Parser (ScriptLookups a)
$cparseJSON :: forall a. Value -> Parser (ScriptLookups a)
FromJSON)

generalise :: ScriptLookups a -> ScriptLookups Any
generalise :: ScriptLookups a -> ScriptLookups Any
generalise ScriptLookups a
sl =
    let validator :: Maybe (TypedValidator Any)
validator = (TypedValidator a -> TypedValidator Any)
-> Maybe (TypedValidator a) -> Maybe (TypedValidator Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypedValidator a -> TypedValidator Any
forall a. TypedValidator a -> TypedValidator Any
Typed.generalise (ScriptLookups a -> Maybe (TypedValidator a)
forall a. ScriptLookups a -> Maybe (TypedValidator a)
slTypedValidator ScriptLookups a
sl)
    in ScriptLookups a
sl{slTypedValidator :: Maybe (TypedValidator Any)
slTypedValidator = Maybe (TypedValidator Any)
validator}

instance Semigroup (ScriptLookups a) where
    ScriptLookups a
l <> :: ScriptLookups a -> ScriptLookups a -> ScriptLookups a
<> ScriptLookups a
r =
        ScriptLookups :: forall a.
Map TxOutRef DecoratedTxOut
-> Map ScriptHash (Versioned Script)
-> Map DatumHash Datum
-> Set PaymentPubKeyHash
-> Maybe (TypedValidator a)
-> Maybe PaymentPubKeyHash
-> Maybe StakingCredential
-> ScriptLookups a
ScriptLookups
            { slTxOutputs :: Map TxOutRef DecoratedTxOut
slTxOutputs = ScriptLookups a -> Map TxOutRef DecoratedTxOut
forall a. ScriptLookups a -> Map TxOutRef DecoratedTxOut
slTxOutputs ScriptLookups a
l Map TxOutRef DecoratedTxOut
-> Map TxOutRef DecoratedTxOut -> Map TxOutRef DecoratedTxOut
forall a. Semigroup a => a -> a -> a
<> ScriptLookups a -> Map TxOutRef DecoratedTxOut
forall a. ScriptLookups a -> Map TxOutRef DecoratedTxOut
slTxOutputs ScriptLookups a
r
            , slOtherScripts :: Map ScriptHash (Versioned Script)
slOtherScripts = ScriptLookups a -> Map ScriptHash (Versioned Script)
forall a. ScriptLookups a -> Map ScriptHash (Versioned Script)
slOtherScripts ScriptLookups a
l Map ScriptHash (Versioned Script)
-> Map ScriptHash (Versioned Script)
-> Map ScriptHash (Versioned Script)
forall a. Semigroup a => a -> a -> a
<> ScriptLookups a -> Map ScriptHash (Versioned Script)
forall a. ScriptLookups a -> Map ScriptHash (Versioned Script)
slOtherScripts ScriptLookups a
r
            , slOtherData :: Map DatumHash Datum
slOtherData = ScriptLookups a -> Map DatumHash Datum
forall a. ScriptLookups a -> Map DatumHash Datum
slOtherData ScriptLookups a
l Map DatumHash Datum -> Map DatumHash Datum -> Map DatumHash Datum
forall a. Semigroup a => a -> a -> a
<> ScriptLookups a -> Map DatumHash Datum
forall a. ScriptLookups a -> Map DatumHash Datum
slOtherData ScriptLookups a
r
            , slPaymentPubKeyHashes :: Set PaymentPubKeyHash
slPaymentPubKeyHashes = ScriptLookups a -> Set PaymentPubKeyHash
forall a. ScriptLookups a -> Set PaymentPubKeyHash
slPaymentPubKeyHashes ScriptLookups a
l Set PaymentPubKeyHash
-> Set PaymentPubKeyHash -> Set PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> ScriptLookups a -> Set PaymentPubKeyHash
forall a. ScriptLookups a -> Set PaymentPubKeyHash
slPaymentPubKeyHashes ScriptLookups a
r
            -- 'First' to match the semigroup instance of Map (left-biased)
            , slTypedValidator :: Maybe (TypedValidator a)
slTypedValidator = (First (TypedValidator a) -> TypedValidator a)
-> Maybe (First (TypedValidator a)) -> Maybe (TypedValidator a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap First (TypedValidator a) -> TypedValidator a
forall a. First a -> a
getFirst (Maybe (First (TypedValidator a)) -> Maybe (TypedValidator a))
-> Maybe (First (TypedValidator a)) -> Maybe (TypedValidator a)
forall a b. (a -> b) -> a -> b
$ (TypedValidator a -> First (TypedValidator a)
forall a. a -> First a
First (TypedValidator a -> First (TypedValidator a))
-> Maybe (TypedValidator a) -> Maybe (First (TypedValidator a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptLookups a -> Maybe (TypedValidator a)
forall a. ScriptLookups a -> Maybe (TypedValidator a)
slTypedValidator ScriptLookups a
l) Maybe (First (TypedValidator a))
-> Maybe (First (TypedValidator a))
-> Maybe (First (TypedValidator a))
forall a. Semigroup a => a -> a -> a
<> (TypedValidator a -> First (TypedValidator a)
forall a. a -> First a
First (TypedValidator a -> First (TypedValidator a))
-> Maybe (TypedValidator a) -> Maybe (First (TypedValidator a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptLookups a -> Maybe (TypedValidator a)
forall a. ScriptLookups a -> Maybe (TypedValidator a)
slTypedValidator ScriptLookups a
r)
            , slOwnPaymentPubKeyHash :: Maybe PaymentPubKeyHash
slOwnPaymentPubKeyHash =
                (First PaymentPubKeyHash -> PaymentPubKeyHash)
-> Maybe (First PaymentPubKeyHash) -> Maybe PaymentPubKeyHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap First PaymentPubKeyHash -> PaymentPubKeyHash
forall a. First a -> a
getFirst (Maybe (First PaymentPubKeyHash) -> Maybe PaymentPubKeyHash)
-> Maybe (First PaymentPubKeyHash) -> Maybe PaymentPubKeyHash
forall a b. (a -> b) -> a -> b
$ (PaymentPubKeyHash -> First PaymentPubKeyHash
forall a. a -> First a
First (PaymentPubKeyHash -> First PaymentPubKeyHash)
-> Maybe PaymentPubKeyHash -> Maybe (First PaymentPubKeyHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptLookups a -> Maybe PaymentPubKeyHash
forall a. ScriptLookups a -> Maybe PaymentPubKeyHash
slOwnPaymentPubKeyHash ScriptLookups a
l)
                             Maybe (First PaymentPubKeyHash)
-> Maybe (First PaymentPubKeyHash)
-> Maybe (First PaymentPubKeyHash)
forall a. Semigroup a => a -> a -> a
<> (PaymentPubKeyHash -> First PaymentPubKeyHash
forall a. a -> First a
First (PaymentPubKeyHash -> First PaymentPubKeyHash)
-> Maybe PaymentPubKeyHash -> Maybe (First PaymentPubKeyHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptLookups a -> Maybe PaymentPubKeyHash
forall a. ScriptLookups a -> Maybe PaymentPubKeyHash
slOwnPaymentPubKeyHash ScriptLookups a
r)
            , slOwnStakingCredential :: Maybe StakingCredential
slOwnStakingCredential =
                (First StakingCredential -> StakingCredential)
-> Maybe (First StakingCredential) -> Maybe StakingCredential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap First StakingCredential -> StakingCredential
forall a. First a -> a
getFirst (Maybe (First StakingCredential) -> Maybe StakingCredential)
-> Maybe (First StakingCredential) -> Maybe StakingCredential
forall a b. (a -> b) -> a -> b
$ (StakingCredential -> First StakingCredential
forall a. a -> First a
First (StakingCredential -> First StakingCredential)
-> Maybe StakingCredential -> Maybe (First StakingCredential)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptLookups a -> Maybe StakingCredential
forall a. ScriptLookups a -> Maybe StakingCredential
slOwnStakingCredential ScriptLookups a
l)
                             Maybe (First StakingCredential)
-> Maybe (First StakingCredential)
-> Maybe (First StakingCredential)
forall a. Semigroup a => a -> a -> a
<> (StakingCredential -> First StakingCredential
forall a. a -> First a
First (StakingCredential -> First StakingCredential)
-> Maybe StakingCredential -> Maybe (First StakingCredential)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptLookups a -> Maybe StakingCredential
forall a. ScriptLookups a -> Maybe StakingCredential
slOwnStakingCredential ScriptLookups a
r)
            }

instance Monoid (ScriptLookups a) where
    mappend :: ScriptLookups a -> ScriptLookups a -> ScriptLookups a
mappend = ScriptLookups a -> ScriptLookups a -> ScriptLookups a
forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: ScriptLookups a
mempty  = Map TxOutRef DecoratedTxOut
-> Map ScriptHash (Versioned Script)
-> Map DatumHash Datum
-> Set PaymentPubKeyHash
-> Maybe (TypedValidator a)
-> Maybe PaymentPubKeyHash
-> Maybe StakingCredential
-> ScriptLookups a
forall a.
Map TxOutRef DecoratedTxOut
-> Map ScriptHash (Versioned Script)
-> Map DatumHash Datum
-> Set PaymentPubKeyHash
-> Maybe (TypedValidator a)
-> Maybe PaymentPubKeyHash
-> Maybe StakingCredential
-> ScriptLookups a
ScriptLookups Map TxOutRef DecoratedTxOut
forall a. Monoid a => a
mempty Map ScriptHash (Versioned Script)
forall a. Monoid a => a
mempty Map DatumHash Datum
forall a. Monoid a => a
mempty Set PaymentPubKeyHash
forall a. Monoid a => a
mempty Maybe (TypedValidator a)
forall a. Maybe a
Nothing Maybe PaymentPubKeyHash
forall a. Maybe a
Nothing Maybe StakingCredential
forall a. Maybe a
Nothing

-- | A script lookups value with a script instance. For convenience this also
--   includes the minting policy script that forwards all checks to the
--   instance's validator.
--
-- If called multiple times, only the first typed validator is kept:
--
-- @
-- typedValidatorLookups tv1 <> typedValidatorLookups tv2 <> ...
--     == typedValidatorLookups tv1
-- @
typedValidatorLookups :: TypedValidator a -> ScriptLookups a
typedValidatorLookups :: TypedValidator a -> ScriptLookups a
typedValidatorLookups TypedValidator a
inst =
    let (ValidatorHash BuiltinByteString
vh, Versioned Validator
v) = (TypedValidator a -> ValidatorHash
forall a. TypedValidator a -> ValidatorHash
tvValidatorHash TypedValidator a
inst, TypedValidator a -> Versioned Validator
forall a. TypedValidator a -> Versioned Validator
tvValidator TypedValidator a
inst)
        (MintingPolicyHash BuiltinByteString
mph, Versioned MintingPolicy
mp) = (TypedValidator a -> MintingPolicyHash
forall a. TypedValidator a -> MintingPolicyHash
Typed.forwardingMintingPolicyHash TypedValidator a
inst, TypedValidator a -> Versioned MintingPolicy
forall a. TypedValidator a -> Versioned MintingPolicy
Typed.vForwardingMintingPolicy TypedValidator a
inst)
    in ScriptLookups Any
forall a. Monoid a => a
mempty
        { slOtherScripts :: Map ScriptHash (Versioned Script)
slOtherScripts =
            [(ScriptHash, Versioned Script)]
-> Map ScriptHash (Versioned Script)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (BuiltinByteString -> ScriptHash
ScriptHash BuiltinByteString
vh, (Validator -> Script) -> Versioned Validator -> Versioned Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Validator -> Script
getValidator Versioned Validator
v)
                         , (BuiltinByteString -> ScriptHash
ScriptHash BuiltinByteString
mph, (MintingPolicy -> Script)
-> Versioned MintingPolicy -> Versioned Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MintingPolicy -> Script
getMintingPolicy Versioned MintingPolicy
mp)
                         ]
        , slTypedValidator :: Maybe (TypedValidator a)
slTypedValidator = TypedValidator a -> Maybe (TypedValidator a)
forall a. a -> Maybe a
Just TypedValidator a
inst
        }

-- | A script lookups value that uses the map of unspent outputs to resolve
--   input constraints.
unspentOutputs :: Map TxOutRef DecoratedTxOut -> ScriptLookups a
unspentOutputs :: Map TxOutRef DecoratedTxOut -> ScriptLookups a
unspentOutputs Map TxOutRef DecoratedTxOut
mp = ScriptLookups a
forall a. Monoid a => a
mempty { slTxOutputs :: Map TxOutRef DecoratedTxOut
slTxOutputs = Map TxOutRef DecoratedTxOut
mp }

-- | A script lookups value with a versioned minting policy script.
mintingPolicy :: Versioned MintingPolicy -> ScriptLookups a
mintingPolicy :: Versioned MintingPolicy -> ScriptLookups a
mintingPolicy ((MintingPolicy -> Script)
-> Versioned MintingPolicy -> Versioned Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MintingPolicy -> Script
getMintingPolicy -> Versioned Script
script) = ScriptLookups a
forall a. Monoid a => a
mempty { slOtherScripts :: Map ScriptHash (Versioned Script)
slOtherScripts = ScriptHash -> Versioned Script -> Map ScriptHash (Versioned Script)
forall k a. k -> a -> Map k a
Map.singleton (Versioned Script -> ScriptHash
P.scriptHash Versioned Script
script) Versioned Script
script }

-- | A script lookups value with a PlutusV1 minting policy script.
plutusV1MintingPolicy :: MintingPolicy -> ScriptLookups a
plutusV1MintingPolicy :: MintingPolicy -> ScriptLookups a
plutusV1MintingPolicy MintingPolicy
pl = Versioned MintingPolicy -> ScriptLookups a
forall a. Versioned MintingPolicy -> ScriptLookups a
mintingPolicy (MintingPolicy -> Language -> Versioned MintingPolicy
forall script. script -> Language -> Versioned script
Versioned MintingPolicy
pl Language
PlutusV1)

-- | A script lookups value with a PlutusV2 minting policy script.
plutusV2MintingPolicy :: MintingPolicy -> ScriptLookups a
plutusV2MintingPolicy :: MintingPolicy -> ScriptLookups a
plutusV2MintingPolicy MintingPolicy
pl = Versioned MintingPolicy -> ScriptLookups a
forall a. Versioned MintingPolicy -> ScriptLookups a
mintingPolicy (MintingPolicy -> Language -> Versioned MintingPolicy
forall script. script -> Language -> Versioned script
Versioned MintingPolicy
pl Language
PlutusV2)

-- | A script lookups value with a versioned validator script.
otherScript :: Versioned Validator -> ScriptLookups a
otherScript :: Versioned Validator -> ScriptLookups a
otherScript ((Validator -> Script) -> Versioned Validator -> Versioned Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Validator -> Script
getValidator -> Versioned Script
script) = ScriptLookups a
forall a. Monoid a => a
mempty { slOtherScripts :: Map ScriptHash (Versioned Script)
slOtherScripts = ScriptHash -> Versioned Script -> Map ScriptHash (Versioned Script)
forall k a. k -> a -> Map k a
Map.singleton (Versioned Script -> ScriptHash
P.scriptHash Versioned Script
script) Versioned Script
script }

-- | A script lookups value with a PlutusV1 validator script.
plutusV1OtherScript :: Validator -> ScriptLookups a
plutusV1OtherScript :: Validator -> ScriptLookups a
plutusV1OtherScript Validator
vl = Versioned Validator -> ScriptLookups a
forall a. Versioned Validator -> ScriptLookups a
otherScript (Validator -> Language -> Versioned Validator
forall script. script -> Language -> Versioned script
Versioned Validator
vl Language
PlutusV1)

-- | A script lookups value with a PlutusV2 validator script.
plutusV2OtherScript :: Validator -> ScriptLookups a
plutusV2OtherScript :: Validator -> ScriptLookups a
plutusV2OtherScript Validator
vl = Versioned Validator -> ScriptLookups a
forall a. Versioned Validator -> ScriptLookups a
otherScript (Validator -> Language -> Versioned Validator
forall script. script -> Language -> Versioned script
Versioned Validator
vl Language
PlutusV2)

-- | A script lookups value with a datum.
otherData :: Datum -> ScriptLookups a
otherData :: Datum -> ScriptLookups a
otherData Datum
dt =
    let dh :: DatumHash
dh = Datum -> DatumHash
P.datumHash Datum
dt in
    ScriptLookups a
forall a. Monoid a => a
mempty { slOtherData :: Map DatumHash Datum
slOtherData = DatumHash -> Datum -> Map DatumHash Datum
forall k a. k -> a -> Map k a
Map.singleton DatumHash
dh Datum
dt }

-- | A script lookups value with a payment public key
paymentPubKey :: PaymentPubKey -> ScriptLookups a
paymentPubKey :: PaymentPubKey -> ScriptLookups a
paymentPubKey (PaymentPubKey PubKey
pk) =
   PaymentPubKeyHash -> ScriptLookups a
forall a. PaymentPubKeyHash -> ScriptLookups a
paymentPubKeyHash (PubKeyHash -> PaymentPubKeyHash
PaymentPubKeyHash (PubKeyHash -> PaymentPubKeyHash)
-> PubKeyHash -> PaymentPubKeyHash
forall a b. (a -> b) -> a -> b
$ PubKey -> PubKeyHash
pubKeyHash PubKey
pk)

-- | A script lookups value with a payment public key
paymentPubKeyHash :: PaymentPubKeyHash -> ScriptLookups a
paymentPubKeyHash :: PaymentPubKeyHash -> ScriptLookups a
paymentPubKeyHash PaymentPubKeyHash
pkh =
    ScriptLookups a
forall a. Monoid a => a
mempty { slPaymentPubKeyHashes :: Set PaymentPubKeyHash
slPaymentPubKeyHashes = PaymentPubKeyHash -> Set PaymentPubKeyHash
forall a. a -> Set a
Set.singleton PaymentPubKeyHash
pkh }

-- | A script lookups value with a payment public key hash.
--
-- If called multiple times, only the first payment public key hash is kept:
--
-- @
-- ownPaymentPubKeyHash pkh1 <> ownPaymentPubKeyHash pkh2 <> ...
--     == ownPaymentPubKeyHash pkh1
-- @
{-# DEPRECATED ownPaymentPubKeyHash "Shouldn't be meaningful due to change in MustSpendAtLeast and MustProduceAtLeast offchain code" #-}
ownPaymentPubKeyHash :: PaymentPubKeyHash -> ScriptLookups a
ownPaymentPubKeyHash :: PaymentPubKeyHash -> ScriptLookups a
ownPaymentPubKeyHash PaymentPubKeyHash
pkh = ScriptLookups a
forall a. Monoid a => a
mempty { slOwnPaymentPubKeyHash :: Maybe PaymentPubKeyHash
slOwnPaymentPubKeyHash = PaymentPubKeyHash -> Maybe PaymentPubKeyHash
forall a. a -> Maybe a
Just PaymentPubKeyHash
pkh }

-- | A script lookups value with staking credentials.
--
-- If called multiple times, only the first staking credential is kept:
--
-- @
-- ownStakingCredential skh1 <> ownStakingCredential skh2 <> ...
--     == ownStakingCredential skh1
-- @
{-# DEPRECATED ownStakingCredential "Shouldn't be meaningful due to change in MustSpendAtLeast and MustProduceAtLeast offchain code" #-}
ownStakingCredential :: StakingCredential -> ScriptLookups a
ownStakingCredential :: StakingCredential -> ScriptLookups a
ownStakingCredential StakingCredential
sc = ScriptLookups a
forall a. Monoid a => a
mempty { slOwnStakingCredential :: Maybe StakingCredential
slOwnStakingCredential = StakingCredential -> Maybe StakingCredential
forall a. a -> Maybe a
Just StakingCredential
sc }

-- | An unbalanced transaction. It needs to be balanced and signed before it
--   can be submitted to the ledger. See note [Submitting transactions from
--   Plutus contracts] in 'Plutus.Contract.Wallet'.
data UnbalancedTx
    = UnbalancedEmulatorTx
        { UnbalancedTx -> Tx
unBalancedEmulatorTx            :: Tx.Tx
        , UnbalancedTx -> Set PaymentPubKeyHash
unBalancedTxRequiredSignatories :: Set PaymentPubKeyHash
        -- ^ These are all the payment public keys that should be used to request the
        -- signatories from the user's wallet. The signatories are what is required to
        -- sign the transaction before submitting it to the blockchain. Transaction
        -- validation will fail if the transaction is not signed by the required wallet.
        , UnbalancedTx -> Map TxOutRef TxOut
unBalancedTxUtxoIndex           :: Map TxOutRef TxOut
        -- ^ Utxo lookups that are used for adding inputs to the 'UnbalancedTx'.
        -- Simply refers to  'slTxOutputs' of 'ScriptLookups'.
        }
    | UnbalancedCardanoTx
        { UnbalancedTx -> CardanoBuildTx
unBalancedCardanoBuildTx :: C.CardanoBuildTx
        , unBalancedTxUtxoIndex    :: Map TxOutRef TxOut
        -- ^ Utxo lookups that are used for adding inputs to the 'UnbalancedTx'.
        -- Simply refers to  'slTxOutputs' of 'ScriptLookups'.
        }
    deriving stock (UnbalancedTx -> UnbalancedTx -> Bool
(UnbalancedTx -> UnbalancedTx -> Bool)
-> (UnbalancedTx -> UnbalancedTx -> Bool) -> Eq UnbalancedTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnbalancedTx -> UnbalancedTx -> Bool
$c/= :: UnbalancedTx -> UnbalancedTx -> Bool
== :: UnbalancedTx -> UnbalancedTx -> Bool
$c== :: UnbalancedTx -> UnbalancedTx -> Bool
Eq, (forall x. UnbalancedTx -> Rep UnbalancedTx x)
-> (forall x. Rep UnbalancedTx x -> UnbalancedTx)
-> Generic UnbalancedTx
forall x. Rep UnbalancedTx x -> UnbalancedTx
forall x. UnbalancedTx -> Rep UnbalancedTx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UnbalancedTx x -> UnbalancedTx
$cfrom :: forall x. UnbalancedTx -> Rep UnbalancedTx x
Generic, Int -> UnbalancedTx -> ShowS
[UnbalancedTx] -> ShowS
UnbalancedTx -> String
(Int -> UnbalancedTx -> ShowS)
-> (UnbalancedTx -> String)
-> ([UnbalancedTx] -> ShowS)
-> Show UnbalancedTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnbalancedTx] -> ShowS
$cshowList :: [UnbalancedTx] -> ShowS
show :: UnbalancedTx -> String
$cshow :: UnbalancedTx -> String
showsPrec :: Int -> UnbalancedTx -> ShowS
$cshowsPrec :: Int -> UnbalancedTx -> ShowS
Show)
    deriving anyclass (Value -> Parser [UnbalancedTx]
Value -> Parser UnbalancedTx
(Value -> Parser UnbalancedTx)
-> (Value -> Parser [UnbalancedTx]) -> FromJSON UnbalancedTx
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UnbalancedTx]
$cparseJSONList :: Value -> Parser [UnbalancedTx]
parseJSON :: Value -> Parser UnbalancedTx
$cparseJSON :: Value -> Parser UnbalancedTx
FromJSON, [UnbalancedTx] -> Encoding
[UnbalancedTx] -> Value
UnbalancedTx -> Encoding
UnbalancedTx -> Value
(UnbalancedTx -> Value)
-> (UnbalancedTx -> Encoding)
-> ([UnbalancedTx] -> Value)
-> ([UnbalancedTx] -> Encoding)
-> ToJSON UnbalancedTx
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UnbalancedTx] -> Encoding
$ctoEncodingList :: [UnbalancedTx] -> Encoding
toJSONList :: [UnbalancedTx] -> Value
$ctoJSONList :: [UnbalancedTx] -> Value
toEncoding :: UnbalancedTx -> Encoding
$ctoEncoding :: UnbalancedTx -> Encoding
toJSON :: UnbalancedTx -> Value
$ctoJSON :: UnbalancedTx -> Value
ToJSON, Typeable UnbalancedTx
Typeable UnbalancedTx
-> (Proxy UnbalancedTx -> Declare (Definitions Schema) NamedSchema)
-> ToSchema UnbalancedTx
Proxy UnbalancedTx -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a
-> (Proxy a -> Declare (Definitions Schema) NamedSchema)
-> ToSchema a
declareNamedSchema :: Proxy UnbalancedTx -> Declare (Definitions Schema) NamedSchema
$cdeclareNamedSchema :: Proxy UnbalancedTx -> Declare (Definitions Schema) NamedSchema
$cp1ToSchema :: Typeable UnbalancedTx
OpenApi.ToSchema)

makeLensesFor
    [ ("unBalancedEmulatorTx", "tx")
    , ("unBalancedCardanoBuildTx", "cardanoTx")
    , ("unBalancedTxRequiredSignatories", "requiredSignatories")
    , ("unBalancedTxUtxoIndex", "utxoIndex")
    ] ''UnbalancedTx

unBalancedTxTx :: UnbalancedTx -> Either C.CardanoBuildTx Tx.Tx
unBalancedTxTx :: UnbalancedTx -> Either CardanoBuildTx Tx
unBalancedTxTx UnbalancedEmulatorTx{Tx
unBalancedEmulatorTx :: Tx
unBalancedEmulatorTx :: UnbalancedTx -> Tx
unBalancedEmulatorTx}    = Tx -> Either CardanoBuildTx Tx
forall a b. b -> Either a b
Right Tx
unBalancedEmulatorTx
unBalancedTxTx UnbalancedCardanoTx{CardanoBuildTx
unBalancedCardanoBuildTx :: CardanoBuildTx
unBalancedCardanoBuildTx :: UnbalancedTx -> CardanoBuildTx
unBalancedCardanoBuildTx} = CardanoBuildTx -> Either CardanoBuildTx Tx
forall a b. a -> Either a b
Left CardanoBuildTx
unBalancedCardanoBuildTx

emptyUnbalancedTx :: UnbalancedTx
emptyUnbalancedTx :: UnbalancedTx
emptyUnbalancedTx = Tx -> Set PaymentPubKeyHash -> Map TxOutRef TxOut -> UnbalancedTx
UnbalancedEmulatorTx Tx
forall a. Monoid a => a
mempty Set PaymentPubKeyHash
forall a. Monoid a => a
mempty Map TxOutRef TxOut
forall a. Monoid a => a
mempty

instance Pretty UnbalancedTx where
    pretty :: UnbalancedTx -> Doc ann
pretty (UnbalancedEmulatorTx Tx
utx Set PaymentPubKeyHash
rs Map TxOutRef TxOut
utxo) =
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"Tx:", Tx -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Tx
utx]
        , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"Requires signatures:" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (PaymentPubKeyHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (PaymentPubKeyHash -> Doc ann) -> [PaymentPubKeyHash] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set PaymentPubKeyHash -> [PaymentPubKeyHash]
forall a. Set a -> [a]
Set.toList Set PaymentPubKeyHash
rs)
        , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"Utxo index:" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((TxOutRef, TxOut) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((TxOutRef, TxOut) -> Doc ann) -> [(TxOutRef, TxOut)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxOutRef TxOut -> [(TxOutRef, TxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxOutRef TxOut
utxo)
        ]
    pretty (UnbalancedCardanoTx CardanoBuildTx
utx Map TxOutRef TxOut
utxo) =
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"Tx (cardano-api Representation):", CardanoBuildTx -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CardanoBuildTx
utx]
        , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"Utxo index:" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((TxOutRef, TxOut) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((TxOutRef, TxOut) -> Doc ann) -> [(TxOutRef, TxOut)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxOutRef TxOut -> [(TxOutRef, TxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxOutRef TxOut
utxo)
        ]

{- Note [Balance of value spent]

To build a transaction that satisfies the 'MustSpendAtLeast' and
'MustProduceAtLeast' constraints, we keep a tally of the required and
actual values we encounter on either side of the transaction. Then we
compute the missing value on both sides, and add an input with the
join of the positive parts [1] of the missing values.

[1] See 'Plutus.V1.Ledger.Value.split'

-}

-- | The balances we track for computing the missing 'Value' (if any)
--   that needs to be added to the transaction.
--   See note [Balance of value spent].
data ValueSpentBalances =
    ValueSpentBalances
        { ValueSpentBalances -> Value
vbsRequired :: Value
        -- ^ Required value spent by the transaction.
        , ValueSpentBalances -> Value
vbsProvided :: Value
        -- ^ Value provided by an input or output of the transaction.
        } deriving (Int -> ValueSpentBalances -> ShowS
[ValueSpentBalances] -> ShowS
ValueSpentBalances -> String
(Int -> ValueSpentBalances -> ShowS)
-> (ValueSpentBalances -> String)
-> ([ValueSpentBalances] -> ShowS)
-> Show ValueSpentBalances
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueSpentBalances] -> ShowS
$cshowList :: [ValueSpentBalances] -> ShowS
show :: ValueSpentBalances -> String
$cshow :: ValueSpentBalances -> String
showsPrec :: Int -> ValueSpentBalances -> ShowS
$cshowsPrec :: Int -> ValueSpentBalances -> ShowS
Show, (forall x. ValueSpentBalances -> Rep ValueSpentBalances x)
-> (forall x. Rep ValueSpentBalances x -> ValueSpentBalances)
-> Generic ValueSpentBalances
forall x. Rep ValueSpentBalances x -> ValueSpentBalances
forall x. ValueSpentBalances -> Rep ValueSpentBalances x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValueSpentBalances x -> ValueSpentBalances
$cfrom :: forall x. ValueSpentBalances -> Rep ValueSpentBalances x
Generic)

instance Semigroup ValueSpentBalances where
    ValueSpentBalances
l <> :: ValueSpentBalances -> ValueSpentBalances -> ValueSpentBalances
<> ValueSpentBalances
r =
        ValueSpentBalances :: Value -> Value -> ValueSpentBalances
ValueSpentBalances
            { vbsRequired :: Value
vbsRequired = ValueSpentBalances -> Value
vbsRequired ValueSpentBalances
l Value -> Value -> Value
forall a. JoinSemiLattice a => a -> a -> a
\/ ValueSpentBalances -> Value
vbsRequired ValueSpentBalances
r
            , vbsProvided :: Value
vbsProvided = ValueSpentBalances -> Value
vbsProvided ValueSpentBalances
l Value -> Value -> Value
forall a. JoinSemiLattice a => a -> a -> a
\/ ValueSpentBalances -> Value
vbsProvided ValueSpentBalances
r
            }

-- No @Monoid ValueSpentBalances@ because @max@ (used by 'convexUnion') is only
-- a semigroup. In this module we only use @Value@s with non-negative amounts,
-- so @mempty :: Value@ technically is the identity, but I'd rather not
-- define the instance. Maybe we need a type for non-negative @Value@s.

data ConstraintProcessingState =
    ConstraintProcessingState
        { ConstraintProcessingState -> UnbalancedTx
cpsUnbalancedTx              :: UnbalancedTx
        -- ^ The unbalanced transaction that we're building
        , ConstraintProcessingState -> ValueSpentBalances
cpsValueSpentBalancesInputs  :: ValueSpentBalances
        -- ^ Balance of the values given and required for the transaction's
        --   inputs
        , ConstraintProcessingState -> ValueSpentBalances
cpsValueSpentBalancesOutputs :: ValueSpentBalances
        -- ^ Balance of the values produced and required for the transaction's
        --   outputs
        , ConstraintProcessingState -> Params
cpsParams                    :: Params
        }

missingValueSpent :: ValueSpentBalances -> Value
missingValueSpent :: ValueSpentBalances -> Value
missingValueSpent ValueSpentBalances{Value
vbsRequired :: Value
vbsRequired :: ValueSpentBalances -> Value
vbsRequired, Value
vbsProvided :: Value
vbsProvided :: ValueSpentBalances -> Value
vbsProvided} =
    let
        difference :: Value
difference = Value
vbsRequired Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
N.negate Value
vbsProvided
        (Value
_, Value
missing) = Value -> (Value, Value)
Value.split Value
difference
    in Value
missing

makeLensesFor
    [ ("cpsUnbalancedTx", "unbalancedTx")
    , ("cpsMintRedeemers", "mintRedeemers")
    , ("cpsValueSpentBalancesInputs", "valueSpentInputs")
    , ("cpsValueSpentBalancesOutputs", "valueSpentOutputs")
    , ("cpsParams", "paramsL")
    ] ''ConstraintProcessingState

initialState :: Params -> ConstraintProcessingState
initialState :: Params -> ConstraintProcessingState
initialState Params
params = ConstraintProcessingState :: UnbalancedTx
-> ValueSpentBalances
-> ValueSpentBalances
-> Params
-> ConstraintProcessingState
ConstraintProcessingState
    { cpsUnbalancedTx :: UnbalancedTx
cpsUnbalancedTx = UnbalancedTx
emptyUnbalancedTx
    , cpsValueSpentBalancesInputs :: ValueSpentBalances
cpsValueSpentBalancesInputs = Value -> Value -> ValueSpentBalances
ValueSpentBalances Value
forall a. Monoid a => a
mempty Value
forall a. Monoid a => a
mempty
    , cpsValueSpentBalancesOutputs :: ValueSpentBalances
cpsValueSpentBalancesOutputs = Value -> Value -> ValueSpentBalances
ValueSpentBalances Value
forall a. Monoid a => a
mempty Value
forall a. Monoid a => a
mempty
    , cpsParams :: Params
cpsParams = Params
params
    }

provided :: Value -> ValueSpentBalances
provided :: Value -> ValueSpentBalances
provided Value
v = ValueSpentBalances :: Value -> Value -> ValueSpentBalances
ValueSpentBalances { vbsProvided :: Value
vbsProvided = Value
v, vbsRequired :: Value
vbsRequired = Value
forall a. Monoid a => a
mempty }

required :: Value -> ValueSpentBalances
required :: Value -> ValueSpentBalances
required Value
v = ValueSpentBalances :: Value -> Value -> ValueSpentBalances
ValueSpentBalances { vbsRequired :: Value
vbsRequired = Value
v, vbsProvided :: Value
vbsProvided = Value
forall a. Monoid a => a
mempty }

-- | Some typed 'TxConstraints' and the 'ScriptLookups' needed to turn them
--   into an 'UnbalancedTx'.
data SomeLookupsAndConstraints where
    SomeLookupsAndConstraints
        :: forall a. (FromData (DatumType a), ToData (DatumType a), ToData (RedeemerType a))
        => ScriptLookups a
        -> TxConstraints (RedeemerType a) (DatumType a)
        -> SomeLookupsAndConstraints

-- | Given a list of 'SomeLookupsAndConstraints' describing the constraints
--   for several scripts, build a single transaction that runs all the scripts.
mkSomeTx
    :: Params
    -> [SomeLookupsAndConstraints]
    -> Either MkTxError UnbalancedTx
mkSomeTx :: Params
-> [SomeLookupsAndConstraints] -> Either MkTxError UnbalancedTx
mkSomeTx Params
params [SomeLookupsAndConstraints]
xs =
    let process :: SomeLookupsAndConstraints
-> StateT ConstraintProcessingState (ExceptT MkTxError Identity) ()
process = \case
            SomeLookupsAndConstraints ScriptLookups a
lookups TxConstraints (RedeemerType a) (DatumType a)
constraints ->
                ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> StateT ConstraintProcessingState (ExceptT MkTxError Identity) ()
forall a (m :: * -> *).
(FromData (DatumType a), ToData (DatumType a),
 ToData (RedeemerType a), MonadState ConstraintProcessingState m,
 MonadError MkTxError m) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a) -> m ()
processLookupsAndConstraints ScriptLookups a
lookups TxConstraints (RedeemerType a) (DatumType a)
constraints
    in (ConstraintProcessingState -> UnbalancedTx)
-> Either MkTxError ConstraintProcessingState
-> Either MkTxError UnbalancedTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstraintProcessingState -> UnbalancedTx
cpsUnbalancedTx
        (Either MkTxError ConstraintProcessingState
 -> Either MkTxError UnbalancedTx)
-> Either MkTxError ConstraintProcessingState
-> Either MkTxError UnbalancedTx
forall a b. (a -> b) -> a -> b
$ Except MkTxError ConstraintProcessingState
-> Either MkTxError ConstraintProcessingState
forall e a. Except e a -> Either e a
runExcept
        (Except MkTxError ConstraintProcessingState
 -> Either MkTxError ConstraintProcessingState)
-> Except MkTxError ConstraintProcessingState
-> Either MkTxError ConstraintProcessingState
forall a b. (a -> b) -> a -> b
$ StateT ConstraintProcessingState (ExceptT MkTxError Identity) [()]
-> ConstraintProcessingState
-> Except MkTxError ConstraintProcessingState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ((SomeLookupsAndConstraints
 -> StateT
      ConstraintProcessingState (ExceptT MkTxError Identity) ())
-> [SomeLookupsAndConstraints]
-> StateT
     ConstraintProcessingState (ExceptT MkTxError Identity) [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SomeLookupsAndConstraints
-> StateT ConstraintProcessingState (ExceptT MkTxError Identity) ()
process [SomeLookupsAndConstraints]
xs) (Params -> ConstraintProcessingState
initialState Params
params)

-- | Filtering MustSpend constraints to ensure their consistency and check that we do not try to spend them
-- with different redeemer or reference scripts.
--
-- When:
--     - 2 or more MustSpendPubkeyOutput are defined for the same output, we only keep the first one
--     - 2 or more MustSpendScriptOutpt are defined for the same output:
--          - if they have different redeemer, we throw an 'AmbiguousRedeemer' error;
--          - if they provide more than one reference script we throw an 'AmbiguousReferenceScript' error;
--          - if only one define a reference script, we use that reference script.
cleaningMustSpendConstraints :: MonadError MkTxError m => [TxConstraint] -> m [TxConstraint]
cleaningMustSpendConstraints :: [TxConstraint] -> m [TxConstraint]
cleaningMustSpendConstraints (x :: TxConstraint
x@(MustSpendScriptOutput TxOutRef
t Redeemer
_ Maybe TxOutRef
_):[TxConstraint]
xs) = do
    let
        spendSame :: TxConstraint -> Bool
spendSame (MustSpendScriptOutput TxOutRef
t' Redeemer
_ Maybe TxOutRef
_) = TxOutRef
t TxOutRef -> TxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== TxOutRef
t'
        spendSame TxConstraint
_                              = Bool
False
        getRedeemer :: TxConstraint -> Maybe Redeemer
getRedeemer (MustSpendScriptOutput TxOutRef
_ Redeemer
r Maybe TxOutRef
_) = Redeemer -> Maybe Redeemer
forall a. a -> Maybe a
Just Redeemer
r
        getRedeemer TxConstraint
_                             = Maybe Redeemer
forall a. Maybe a
Nothing
        getReferenceScript :: TxConstraint -> Maybe TxOutRef
getReferenceScript (MustSpendScriptOutput TxOutRef
_ Redeemer
_ Maybe TxOutRef
rs) = Maybe TxOutRef
rs
        getReferenceScript TxConstraint
_                              = Maybe TxOutRef
forall a. Maybe a
Nothing
        ([TxConstraint]
mustSpendSame, [TxConstraint]
otherConstraints) = (TxConstraint -> Bool)
-> [TxConstraint] -> ([TxConstraint], [TxConstraint])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition TxConstraint -> Bool
spendSame [TxConstraint]
xs
        redeemers :: Set Redeemer
redeemers = [Redeemer] -> Set Redeemer
forall a. Ord a => [a] -> Set a
Set.fromList ([Redeemer] -> Set Redeemer) -> [Redeemer] -> Set Redeemer
forall a b. (a -> b) -> a -> b
$ (TxConstraint -> Maybe Redeemer) -> [TxConstraint] -> [Redeemer]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxConstraint -> Maybe Redeemer
getRedeemer (TxConstraint
xTxConstraint -> [TxConstraint] -> [TxConstraint]
forall a. a -> [a] -> [a]
:[TxConstraint]
mustSpendSame)
        referenceScripts :: Set TxOutRef
referenceScripts = [TxOutRef] -> Set TxOutRef
forall a. Ord a => [a] -> Set a
Set.fromList ([TxOutRef] -> Set TxOutRef) -> [TxOutRef] -> Set TxOutRef
forall a b. (a -> b) -> a -> b
$ (TxConstraint -> Maybe TxOutRef) -> [TxConstraint] -> [TxOutRef]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxConstraint -> Maybe TxOutRef
getReferenceScript (TxConstraint
xTxConstraint -> [TxConstraint] -> [TxConstraint]
forall a. a -> [a] -> [a]
:[TxConstraint]
mustSpendSame)
    Redeemer
red <- case Set Redeemer -> [Redeemer]
forall a. Set a -> [a]
Set.toList Set Redeemer
redeemers of
                []    -> MkTxError -> m Redeemer
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m Redeemer) -> MkTxError -> m Redeemer
forall a b. (a -> b) -> a -> b
$ TxOutRef -> [Redeemer] -> MkTxError
AmbiguousRedeemer TxOutRef
t [] -- Can't happen as x must have a redeemer
                [Redeemer
red] -> Redeemer -> m Redeemer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Redeemer
red
                [Redeemer]
rs    -> MkTxError -> m Redeemer
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m Redeemer) -> MkTxError -> m Redeemer
forall a b. (a -> b) -> a -> b
$ TxOutRef -> [Redeemer] -> MkTxError
AmbiguousRedeemer TxOutRef
t [Redeemer]
rs
    Maybe TxOutRef
rs  <- case Set TxOutRef -> [TxOutRef]
forall a. Set a -> [a]
Set.toList Set TxOutRef
referenceScripts of
                []  -> Maybe TxOutRef -> m (Maybe TxOutRef)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TxOutRef
forall a. Maybe a
Nothing
                [TxOutRef
r] -> Maybe TxOutRef -> m (Maybe TxOutRef)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TxOutRef -> m (Maybe TxOutRef))
-> Maybe TxOutRef -> m (Maybe TxOutRef)
forall a b. (a -> b) -> a -> b
$ TxOutRef -> Maybe TxOutRef
forall a. a -> Maybe a
Just TxOutRef
r
                [TxOutRef]
rs  -> MkTxError -> m (Maybe TxOutRef)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m (Maybe TxOutRef))
-> MkTxError -> m (Maybe TxOutRef)
forall a b. (a -> b) -> a -> b
$ TxOutRef -> [TxOutRef] -> MkTxError
AmbiguousReferenceScript TxOutRef
t [TxOutRef]
rs
    (TxOutRef -> Redeemer -> Maybe TxOutRef -> TxConstraint
MustSpendScriptOutput TxOutRef
t Redeemer
red Maybe TxOutRef
rsTxConstraint -> [TxConstraint] -> [TxConstraint]
forall a. a -> [a] -> [a]
:) ([TxConstraint] -> [TxConstraint])
-> m [TxConstraint] -> m [TxConstraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxConstraint] -> m [TxConstraint]
forall (m :: * -> *).
MonadError MkTxError m =>
[TxConstraint] -> m [TxConstraint]
cleaningMustSpendConstraints [TxConstraint]
otherConstraints
cleaningMustSpendConstraints (x :: TxConstraint
x@(MustSpendPubKeyOutput TxOutRef
_):[TxConstraint]
xs) =
    (TxConstraint
x TxConstraint -> [TxConstraint] -> [TxConstraint]
forall a. a -> [a] -> [a]
:) ([TxConstraint] -> [TxConstraint])
-> m [TxConstraint] -> m [TxConstraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxConstraint] -> m [TxConstraint]
forall (m :: * -> *).
MonadError MkTxError m =>
[TxConstraint] -> m [TxConstraint]
cleaningMustSpendConstraints ((TxConstraint -> Bool) -> [TxConstraint] -> [TxConstraint]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxConstraint
x TxConstraint -> TxConstraint -> Bool
forall a. Eq a => a -> a -> Bool
/=) [TxConstraint]
xs)
cleaningMustSpendConstraints [] = [TxConstraint] -> m [TxConstraint]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
cleaningMustSpendConstraints (TxConstraint
x:[TxConstraint]
xs) = (TxConstraint
x TxConstraint -> [TxConstraint] -> [TxConstraint]
forall a. a -> [a] -> [a]
:) ([TxConstraint] -> [TxConstraint])
-> m [TxConstraint] -> m [TxConstraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxConstraint] -> m [TxConstraint]
forall (m :: * -> *).
MonadError MkTxError m =>
[TxConstraint] -> m [TxConstraint]
cleaningMustSpendConstraints [TxConstraint]
xs


prepareConstraints
    :: ( ToData (DatumType a)
       , MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => [ScriptOutputConstraint (DatumType a)]
    -> [TxConstraint]
    -> m [TxConstraint]
prepareConstraints :: [ScriptOutputConstraint (DatumType a)]
-> [TxConstraint] -> m [TxConstraint]
prepareConstraints [ScriptOutputConstraint (DatumType a)]
ownOutputs [TxConstraint]
constraints = do
    [TxConstraint]
ownOutputConstraints <- [[TxConstraint]] -> [TxConstraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TxConstraint]] -> [TxConstraint])
-> m [[TxConstraint]] -> m [TxConstraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ScriptOutputConstraint (DatumType a) -> m [TxConstraint])
-> [ScriptOutputConstraint (DatumType a)] -> m [[TxConstraint]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptOutputConstraint (DatumType a) -> m [TxConstraint]
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m,
 ToData (DatumType a)) =>
ScriptOutputConstraint (DatumType a) -> m [TxConstraint]
addOwnOutput [ScriptOutputConstraint (DatumType a)]
ownOutputs
    [TxConstraint]
cleanedConstraints <- [TxConstraint] -> m [TxConstraint]
forall (m :: * -> *).
MonadError MkTxError m =>
[TxConstraint] -> m [TxConstraint]
cleaningMustSpendConstraints [TxConstraint]
constraints
    [TxConstraint] -> m [TxConstraint]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxConstraint]
cleanedConstraints [TxConstraint] -> [TxConstraint] -> [TxConstraint]
forall a. Semigroup a => a -> a -> a
<> [TxConstraint]
ownOutputConstraints)

-- | Resolve some 'TxConstraints' by modifying the 'UnbalancedTx' in the
--   'ConstraintProcessingState'
processLookupsAndConstraints
    :: ( FromData (DatumType a)
       , ToData (DatumType a)
       , ToData (RedeemerType a)
       , MonadState ConstraintProcessingState m
       , MonadError MkTxError m
       )
    => ScriptLookups a
    -> TxConstraints (RedeemerType a) (DatumType a)
    -> m ()
processLookupsAndConstraints :: ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a) -> m ()
processLookupsAndConstraints ScriptLookups a
lookups TxConstraints{[TxConstraint]
txConstraints :: [TxConstraint]
txConstraints :: forall i o. TxConstraints i o -> [TxConstraint]
txConstraints, [ScriptInputConstraint (RedeemerType a)]
txOwnInputs :: [ScriptInputConstraint (RedeemerType a)]
txOwnInputs :: forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs, [ScriptOutputConstraint (DatumType a)]
txOwnOutputs :: [ScriptOutputConstraint (DatumType a)]
txOwnOutputs :: forall i o. TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs, txConstraintFuns :: forall i o. TxConstraints i o -> TxConstraintFuns
txConstraintFuns = TxConstraintFuns [TxConstraintFun]
txCnsFuns } =
    (ReaderT (ScriptLookups a) m () -> ScriptLookups a -> m ())
-> ScriptLookups a -> ReaderT (ScriptLookups a) m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (ScriptLookups a) m () -> ScriptLookups a -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ScriptLookups a
lookups (ReaderT (ScriptLookups a) m () -> m ())
-> ReaderT (ScriptLookups a) m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
         [TxConstraint]
constraints <- [ScriptOutputConstraint (DatumType a)]
-> [TxConstraint] -> ReaderT (ScriptLookups a) m [TxConstraint]
forall a (m :: * -> *).
(ToData (DatumType a), MonadReader (ScriptLookups a) m,
 MonadError MkTxError m) =>
[ScriptOutputConstraint (DatumType a)]
-> [TxConstraint] -> m [TxConstraint]
prepareConstraints [ScriptOutputConstraint (DatumType a)]
txOwnOutputs [TxConstraint]
txConstraints
         (TxConstraint -> ReaderT (ScriptLookups a) m ())
-> [TxConstraint] -> ReaderT (ScriptLookups a) m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TxConstraint -> ReaderT (ScriptLookups a) m ()
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m,
 MonadState ConstraintProcessingState m) =>
TxConstraint -> m ()
processConstraint [TxConstraint]
constraints
         (TxConstraintFun -> ReaderT (ScriptLookups a) m ())
-> [TxConstraintFun] -> ReaderT (ScriptLookups a) m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TxConstraintFun -> ReaderT (ScriptLookups a) m ()
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m,
 MonadState ConstraintProcessingState m) =>
TxConstraintFun -> m ()
processConstraintFun [TxConstraintFun]
txCnsFuns
         (ScriptInputConstraint (RedeemerType a)
 -> ReaderT (ScriptLookups a) m ())
-> [ScriptInputConstraint (RedeemerType a)]
-> ReaderT (ScriptLookups a) m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ScriptInputConstraint (RedeemerType a)
-> ReaderT (ScriptLookups a) m ()
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m,
 MonadState ConstraintProcessingState m, FromData (DatumType a),
 ToData (DatumType a), ToData (RedeemerType a)) =>
ScriptInputConstraint (RedeemerType a) -> m ()
addOwnInput [ScriptInputConstraint (RedeemerType a)]
txOwnInputs
         ReaderT (ScriptLookups a) m ()
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m,
 MonadState ConstraintProcessingState m, MonadError MkTxError m) =>
m ()
checkValueSpent
         ReaderT (ScriptLookups a) m ()
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m,
 MonadState ConstraintProcessingState m, MonadError MkTxError m) =>
m ()
updateUtxoIndex


checkValueSpent
    :: ( MonadReader (ScriptLookups a) m
       , MonadState ConstraintProcessingState m
       , MonadError MkTxError m
       )
    => m ()
checkValueSpent :: m ()
checkValueSpent = do
    Value
missingInputs <- LensLike'
  (Const Value) ConstraintProcessingState ValueSpentBalances
-> (ValueSpentBalances -> Value) -> m Value
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
  (Const Value) ConstraintProcessingState ValueSpentBalances
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentInputs ValueSpentBalances -> Value
missingValueSpent
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> Bool
Value.isZero Value
missingInputs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m ()) -> MkTxError -> m ()
forall a b. (a -> b) -> a -> b
$ Value -> MkTxError
DeclaredInputMismatch Value
missingInputs
    Value
missingOutputs <- LensLike'
  (Const Value) ConstraintProcessingState ValueSpentBalances
-> (ValueSpentBalances -> Value) -> m Value
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
  (Const Value) ConstraintProcessingState ValueSpentBalances
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentOutputs ValueSpentBalances -> Value
missingValueSpent
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> Bool
Value.isZero Value
missingOutputs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m ()) -> MkTxError -> m ()
forall a b. (a -> b) -> a -> b
$ Value -> MkTxError
DeclaredOutputMismatch Value
missingOutputs

-- | Turn a 'TxConstraints' value into an unbalanced transaction that satisfies
--   the constraints. To use this in a contract, see
--   'Plutus.Contract.submitTxConstraints'
--   and related functions.
--   Uses default 'Params' which is probably not what you want, use 'mkTxWithParams' instead.
{-# DEPRECATED mkTx "Use mkTxWithParams instead" #-}
mkTx
    :: ( FromData (DatumType a)
       , ToData (DatumType a)
       , ToData (RedeemerType a)
       )
    => ScriptLookups a
    -> TxConstraints (RedeemerType a) (DatumType a)
    -> Either MkTxError UnbalancedTx
mkTx :: ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Either MkTxError UnbalancedTx
mkTx = Params
-> ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Either MkTxError UnbalancedTx
forall a.
(FromData (DatumType a), ToData (DatumType a),
 ToData (RedeemerType a)) =>
Params
-> ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Either MkTxError UnbalancedTx
mkTxWithParams Params
forall a. Default a => a
def

-- | Turn a 'TxConstraints' value into an unbalanced transaction that satisfies
--   the constraints. To use this in a contract, see
--   'Plutus.Contract.submitTxConstraints'
--   and related functions.
mkTxWithParams
    :: ( FromData (DatumType a)
       , ToData (DatumType a)
       , ToData (RedeemerType a)
       )
    => Params
    -> ScriptLookups a
    -> TxConstraints (RedeemerType a) (DatumType a)
    -> Either MkTxError UnbalancedTx
mkTxWithParams :: Params
-> ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Either MkTxError UnbalancedTx
mkTxWithParams Params
params ScriptLookups a
lookups TxConstraints (RedeemerType a) (DatumType a)
txc = Params
-> [SomeLookupsAndConstraints] -> Either MkTxError UnbalancedTx
mkSomeTx Params
params [ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> SomeLookupsAndConstraints
forall a.
(FromData (DatumType a), ToData (DatumType a),
 ToData (RedeemerType a)) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> SomeLookupsAndConstraints
SomeLookupsAndConstraints ScriptLookups a
lookups TxConstraints (RedeemerType a) (DatumType a)
txc]

-- | Each transaction output should contain a minimum amount of Ada (this is a
-- restriction on the real Cardano network).
adjustUnbalancedTx :: PParams -> UnbalancedTx -> Either Tx.ToCardanoError ([Ada.Ada], UnbalancedTx)
adjustUnbalancedTx :: PParams
-> UnbalancedTx -> Either ToCardanoError ([Ada], UnbalancedTx)
adjustUnbalancedTx PParams
params = (Unwrapped
   (Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx)
 -> Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx)
-> ((TxOut -> Compose (Either ToCardanoError) ((,) [Ada]) TxOut)
    -> UnbalancedTx
    -> Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx)
-> (TxOut
    -> Unwrapped (Compose (Either ToCardanoError) ((,) [Ada]) TxOut))
-> UnbalancedTx
-> Unwrapped
     (Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx)
forall (f :: * -> *) (g :: * -> *) s t.
(Functor f, Functor g, Rewrapping s t) =>
(Unwrapped s -> s)
-> (f t -> g s) -> f (Unwrapped t) -> g (Unwrapped s)
alaf Unwrapped
  (Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx)
-> Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((Tx -> Compose (Either ToCardanoError) ((,) [Ada]) Tx)
-> UnbalancedTx
-> Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Compose (Either ToCardanoError) ((,) [Ada]) Tx)
 -> UnbalancedTx
 -> Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx)
-> ((TxOut -> Compose (Either ToCardanoError) ((,) [Ada]) TxOut)
    -> Tx -> Compose (Either ToCardanoError) ((,) [Ada]) Tx)
-> (TxOut -> Compose (Either ToCardanoError) ((,) [Ada]) TxOut)
-> UnbalancedTx
-> Compose (Either ToCardanoError) ((,) [Ada]) UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxOut] -> Compose (Either ToCardanoError) ((,) [Ada]) [TxOut])
-> Tx -> Compose (Either ToCardanoError) ((,) [Ada]) Tx
Lens' Tx [TxOut]
Tx.outputs (([TxOut] -> Compose (Either ToCardanoError) ((,) [Ada]) [TxOut])
 -> Tx -> Compose (Either ToCardanoError) ((,) [Ada]) Tx)
-> ((TxOut -> Compose (Either ToCardanoError) ((,) [Ada]) TxOut)
    -> [TxOut] -> Compose (Either ToCardanoError) ((,) [Ada]) [TxOut])
-> (TxOut -> Compose (Either ToCardanoError) ((,) [Ada]) TxOut)
-> Tx
-> Compose (Either ToCardanoError) ((,) [Ada]) Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> Compose (Either ToCardanoError) ((,) [Ada]) TxOut)
-> [TxOut] -> Compose (Either ToCardanoError) ((,) [Ada]) [TxOut]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (PParams -> TxOut -> Either ToCardanoError ([Ada], TxOut)
adjustTxOut PParams
params)


updateUtxoIndex
    :: ( MonadReader (ScriptLookups a) m
       , MonadState ConstraintProcessingState m
       , MonadError MkTxError m
       )
    => m ()
updateUtxoIndex :: m ()
updateUtxoIndex = do
    ScriptLookups{Map TxOutRef DecoratedTxOut
slTxOutputs :: Map TxOutRef DecoratedTxOut
slTxOutputs :: forall a. ScriptLookups a -> Map TxOutRef DecoratedTxOut
slTxOutputs} <- m (ScriptLookups a)
forall r (m :: * -> *). MonadReader r m => m r
ask
    NetworkId
networkId <- (ConstraintProcessingState -> NetworkId) -> m NetworkId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((ConstraintProcessingState -> NetworkId) -> m NetworkId)
-> (ConstraintProcessingState -> NetworkId) -> m NetworkId
forall a b. (a -> b) -> a -> b
$ Params -> NetworkId
pNetworkId (Params -> NetworkId)
-> (ConstraintProcessingState -> Params)
-> ConstraintProcessingState
-> NetworkId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintProcessingState -> Params
cpsParams
    Map TxOutRef TxOut
slUtxos <- (DecoratedTxOut -> m TxOut)
-> Map TxOutRef DecoratedTxOut -> m (Map TxOutRef TxOut)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Either ToCardanoError TxOut -> m TxOut
forall (m :: * -> *) a.
MonadError MkTxError m =>
Either ToCardanoError a -> m a
throwToCardanoError (Either ToCardanoError TxOut -> m TxOut)
-> (DecoratedTxOut -> Either ToCardanoError TxOut)
-> DecoratedTxOut
-> m TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkId -> DecoratedTxOut -> Either ToCardanoError TxOut
Tx.toTxOut NetworkId
networkId) Map TxOutRef DecoratedTxOut
slTxOutputs
    (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Map TxOutRef TxOut -> Identity (Map TxOutRef TxOut))
    -> UnbalancedTx -> Identity UnbalancedTx)
-> (Map TxOutRef TxOut -> Identity (Map TxOutRef TxOut))
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map TxOutRef TxOut -> Identity (Map TxOutRef TxOut))
-> UnbalancedTx -> Identity UnbalancedTx
Lens' UnbalancedTx (Map TxOutRef TxOut)
utxoIndex ((Map TxOutRef TxOut -> Identity (Map TxOutRef TxOut))
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> Map TxOutRef TxOut -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Map TxOutRef TxOut
slUtxos

-- | Add a typed input, checking the type of the output it spends. Return the value
--   of the spent output.
addOwnInput
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       , MonadState ConstraintProcessingState m
       , FromData (DatumType a)
       , ToData (DatumType a)
       , ToData (RedeemerType a)
       )
    => ScriptInputConstraint (RedeemerType a)
    -> m ()
addOwnInput :: ScriptInputConstraint (RedeemerType a) -> m ()
addOwnInput ScriptInputConstraint{RedeemerType a
icRedeemer :: RedeemerType a
icRedeemer :: forall a. ScriptInputConstraint a -> a
icRedeemer, TxOutRef
icTxOutRef :: TxOutRef
icTxOutRef :: forall a. ScriptInputConstraint a -> TxOutRef
icTxOutRef} = do
    ScriptLookups{Map TxOutRef DecoratedTxOut
slTxOutputs :: Map TxOutRef DecoratedTxOut
slTxOutputs :: forall a. ScriptLookups a -> Map TxOutRef DecoratedTxOut
slTxOutputs, Maybe (TypedValidator a)
slTypedValidator :: Maybe (TypedValidator a)
slTypedValidator :: forall a. ScriptLookups a -> Maybe (TypedValidator a)
slTypedValidator} <- m (ScriptLookups a)
forall r (m :: * -> *). MonadReader r m => m r
ask
    TypedValidator a
inst <- m (TypedValidator a)
-> (TypedValidator a -> m (TypedValidator a))
-> Maybe (TypedValidator a)
-> m (TypedValidator a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MkTxError -> m (TypedValidator a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MkTxError
TypedValidatorMissing) TypedValidator a -> m (TypedValidator a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypedValidator a)
slTypedValidator
    TypedScriptTxOutRef a
typedOutRef <-
      (ConnectionError -> m (TypedScriptTxOutRef a))
-> (TypedScriptTxOutRef a -> m (TypedScriptTxOutRef a))
-> Either ConnectionError (TypedScriptTxOutRef a)
-> m (TypedScriptTxOutRef a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MkTxError -> m (TypedScriptTxOutRef a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m (TypedScriptTxOutRef a))
-> (ConnectionError -> MkTxError)
-> ConnectionError
-> m (TypedScriptTxOutRef a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionError -> MkTxError
TypeCheckFailed) TypedScriptTxOutRef a -> m (TypedScriptTxOutRef a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either ConnectionError (TypedScriptTxOutRef a)
 -> m (TypedScriptTxOutRef a))
-> Either ConnectionError (TypedScriptTxOutRef a)
-> m (TypedScriptTxOutRef a)
forall a b. (a -> b) -> a -> b
$ forall a. Except ConnectionError a -> Either ConnectionError a
forall e a. Except e a -> Either e a
runExcept @Typed.ConnectionError
      (Except ConnectionError (TypedScriptTxOutRef a)
 -> Either ConnectionError (TypedScriptTxOutRef a))
-> Except ConnectionError (TypedScriptTxOutRef a)
-> Either ConnectionError (TypedScriptTxOutRef a)
forall a b. (a -> b) -> a -> b
$ do
          (TxOut
txOut, Datum
datum) <- ExceptT ConnectionError Identity (TxOut, Datum)
-> ((TxOut, Datum)
    -> ExceptT ConnectionError Identity (TxOut, Datum))
-> Maybe (TxOut, Datum)
-> ExceptT ConnectionError Identity (TxOut, Datum)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectionError -> ExceptT ConnectionError Identity (TxOut, Datum)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ConnectionError
 -> ExceptT ConnectionError Identity (TxOut, Datum))
-> ConnectionError
-> ExceptT ConnectionError Identity (TxOut, Datum)
forall a b. (a -> b) -> a -> b
$ TxOutRef -> ConnectionError
UnknownRef TxOutRef
icTxOutRef) (TxOut, Datum) -> ExceptT ConnectionError Identity (TxOut, Datum)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TxOut, Datum)
 -> ExceptT ConnectionError Identity (TxOut, Datum))
-> Maybe (TxOut, Datum)
-> ExceptT ConnectionError Identity (TxOut, Datum)
forall a b. (a -> b) -> a -> b
$ do
                                DecoratedTxOut
ciTxOut <- TxOutRef -> Map TxOutRef DecoratedTxOut -> Maybe DecoratedTxOut
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxOutRef
icTxOutRef Map TxOutRef DecoratedTxOut
slTxOutputs
                                Datum
datum <- DecoratedTxOut
ciTxOut DecoratedTxOut
-> Getting (First Datum) DecoratedTxOut Datum -> Maybe Datum
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((DatumHash, DatumFromQuery)
 -> Const (First Datum) (DatumHash, DatumFromQuery))
-> DecoratedTxOut -> Const (First Datum) DecoratedTxOut
Traversal' DecoratedTxOut (DatumHash, DatumFromQuery)
Tx.decoratedTxOutDatum (((DatumHash, DatumFromQuery)
  -> Const (First Datum) (DatumHash, DatumFromQuery))
 -> DecoratedTxOut -> Const (First Datum) DecoratedTxOut)
-> ((Datum -> Const (First Datum) Datum)
    -> (DatumHash, DatumFromQuery)
    -> Const (First Datum) (DatumHash, DatumFromQuery))
-> Getting (First Datum) DecoratedTxOut Datum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DatumFromQuery -> Const (First Datum) DatumFromQuery)
-> (DatumHash, DatumFromQuery)
-> Const (First Datum) (DatumHash, DatumFromQuery)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((DatumFromQuery -> Const (First Datum) DatumFromQuery)
 -> (DatumHash, DatumFromQuery)
 -> Const (First Datum) (DatumHash, DatumFromQuery))
-> ((Datum -> Const (First Datum) Datum)
    -> DatumFromQuery -> Const (First Datum) DatumFromQuery)
-> (Datum -> Const (First Datum) Datum)
-> (DatumHash, DatumFromQuery)
-> Const (First Datum) (DatumHash, DatumFromQuery)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Datum -> Const (First Datum) Datum)
-> DatumFromQuery -> Const (First Datum) DatumFromQuery
Traversal' DatumFromQuery Datum
Tx.datumInDatumFromQuery
                                (TxOut, Datum) -> Maybe (TxOut, Datum)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DecoratedTxOut -> TxOut
Tx.toTxInfoTxOut DecoratedTxOut
ciTxOut, Datum
datum)
          TypedValidator a
-> TxOutRef
-> TxOut
-> Datum
-> Except ConnectionError (TypedScriptTxOutRef a)
forall out (m :: * -> *).
(FromData (DatumType out), ToData (DatumType out),
 MonadError ConnectionError m) =>
TypedValidator out
-> TxOutRef -> TxOut -> Datum -> m (TypedScriptTxOutRef out)
Typed.typeScriptTxOutRef TypedValidator a
inst TxOutRef
icTxOutRef TxOut
txOut Datum
datum
    let vl :: Value
vl = TxOut -> Value
PV2.txOutValue (TxOut -> Value) -> TxOut -> Value
forall a b. (a -> b) -> a -> b
$ TypedScriptTxOut a -> TxOut
forall a. TypedScriptTxOut a -> TxOut
Typed.tyTxOutTxOut (TypedScriptTxOut a -> TxOut) -> TypedScriptTxOut a -> TxOut
forall a b. (a -> b) -> a -> b
$ TypedScriptTxOutRef a -> TypedScriptTxOut a
forall a. TypedScriptTxOutRef a -> TypedScriptTxOut a
Typed.tyTxOutRefOut TypedScriptTxOutRef a
typedOutRef
    (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentInputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
provided Value
vl
    case TypedScriptTxOutRef a
typedOutRef of
        Typed.TypedScriptTxOutRef{TxOutRef
tyTxOutRefRef :: forall a. TypedScriptTxOutRef a -> TxOutRef
tyTxOutRefRef :: TxOutRef
Typed.tyTxOutRefRef, TypedScriptTxOut a
tyTxOutRefOut :: TypedScriptTxOut a
tyTxOutRefOut :: forall a. TypedScriptTxOutRef a -> TypedScriptTxOut a
Typed.tyTxOutRefOut} -> do
            let datum :: Datum
datum = BuiltinData -> Datum
Datum (BuiltinData -> Datum) -> BuiltinData -> Datum
forall a b. (a -> b) -> a -> b
$ DatumType a -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData (DatumType a -> BuiltinData) -> DatumType a -> BuiltinData
forall a b. (a -> b) -> a -> b
$ TypedScriptTxOut a -> DatumType a
forall a. TypedScriptTxOut a -> DatumType a
Typed.tyTxOutData TypedScriptTxOut a
tyTxOutRefOut
            (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (Tx -> Identity Tx)
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (Tx -> Tx) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= TxOutRef
-> Versioned Validator -> Redeemer -> Maybe Datum -> Tx -> Tx
Tx.addScriptTxInput
                                      TxOutRef
tyTxOutRefRef
                                      (TypedValidator a -> Versioned Validator
forall a. TypedValidator a -> Versioned Validator
Typed.vValidatorScript TypedValidator a
inst)
                                      (BuiltinData -> Redeemer
Redeemer (BuiltinData -> Redeemer) -> BuiltinData -> Redeemer
forall a b. (a -> b) -> a -> b
$ RedeemerType a -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData RedeemerType a
icRedeemer)
                                      (Datum -> Maybe Datum
forall a. a -> Maybe a
Just Datum
datum)

-- | Convert a @ScriptOutputConstraint@ into a @TxConstraint@.
addOwnOutput
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       , ToData (DatumType a)
       )
    => ScriptOutputConstraint (DatumType a)
    -> m [TxConstraint]
addOwnOutput :: ScriptOutputConstraint (DatumType a) -> m [TxConstraint]
addOwnOutput ScriptOutputConstraint{TxOutDatum (DatumType a)
ocDatum :: TxOutDatum (DatumType a)
ocDatum :: forall a. ScriptOutputConstraint a -> TxOutDatum a
ocDatum, Value
ocValue :: Value
ocValue :: forall a. ScriptOutputConstraint a -> Value
ocValue, Maybe ScriptHash
ocReferenceScriptHash :: Maybe ScriptHash
ocReferenceScriptHash :: forall a. ScriptOutputConstraint a -> Maybe ScriptHash
ocReferenceScriptHash} = do
    ScriptLookups{Maybe (TypedValidator a)
slTypedValidator :: Maybe (TypedValidator a)
slTypedValidator :: forall a. ScriptLookups a -> Maybe (TypedValidator a)
slTypedValidator} <- m (ScriptLookups a)
forall r (m :: * -> *). MonadReader r m => m r
ask
    TypedValidator a
inst <- m (TypedValidator a)
-> (TypedValidator a -> m (TypedValidator a))
-> Maybe (TypedValidator a)
-> m (TypedValidator a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MkTxError -> m (TypedValidator a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MkTxError
TypedValidatorMissing) TypedValidator a -> m (TypedValidator a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypedValidator a)
slTypedValidator
    let dsV :: TxOutDatum Datum
dsV = (DatumType a -> Datum)
-> TxOutDatum (DatumType a) -> TxOutDatum Datum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BuiltinData -> Datum
Datum (BuiltinData -> Datum)
-> (DatumType a -> BuiltinData) -> DatumType a -> Datum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatumType a -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData) TxOutDatum (DatumType a)
ocDatum
    [TxConstraint] -> m [TxConstraint]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Address
-> Maybe (TxOutDatum Datum)
-> Maybe ScriptHash
-> Value
-> TxConstraint
MustPayToAddress (TypedValidator a -> Address
forall a. TypedValidator a -> Address
validatorAddress TypedValidator a
inst) (TxOutDatum Datum -> Maybe (TxOutDatum Datum)
forall a. a -> Maybe a
Just TxOutDatum Datum
dsV) Maybe ScriptHash
ocReferenceScriptHash Value
ocValue ]

lookupTxOutRef
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => TxOutRef
    -> m DecoratedTxOut
lookupTxOutRef :: TxOutRef -> m DecoratedTxOut
lookupTxOutRef TxOutRef
outRef =
    let err :: m DecoratedTxOut
err = MkTxError -> m DecoratedTxOut
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxOutRef -> MkTxError
TxOutRefNotFound TxOutRef
outRef) in
    (ScriptLookups a -> Map TxOutRef DecoratedTxOut)
-> m (Map TxOutRef DecoratedTxOut)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ScriptLookups a -> Map TxOutRef DecoratedTxOut
forall a. ScriptLookups a -> Map TxOutRef DecoratedTxOut
slTxOutputs m (Map TxOutRef DecoratedTxOut)
-> (Map TxOutRef DecoratedTxOut -> m DecoratedTxOut)
-> m DecoratedTxOut
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m DecoratedTxOut
-> (DecoratedTxOut -> m DecoratedTxOut)
-> Maybe DecoratedTxOut
-> m DecoratedTxOut
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m DecoratedTxOut
err DecoratedTxOut -> m DecoratedTxOut
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DecoratedTxOut -> m DecoratedTxOut)
-> (Map TxOutRef DecoratedTxOut -> Maybe DecoratedTxOut)
-> Map TxOutRef DecoratedTxOut
-> m DecoratedTxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Maybe DecoratedTxOut)
  (Map TxOutRef DecoratedTxOut)
  (Maybe DecoratedTxOut)
-> Map TxOutRef DecoratedTxOut -> Maybe DecoratedTxOut
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Index (Map TxOutRef DecoratedTxOut)
-> Lens'
     (Map TxOutRef DecoratedTxOut)
     (Maybe (IxValue (Map TxOutRef DecoratedTxOut)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map TxOutRef DecoratedTxOut)
TxOutRef
outRef)

lookupDatum
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => DatumHash
    -> m Datum
lookupDatum :: DatumHash -> m Datum
lookupDatum DatumHash
dvh =
    let err :: m Datum
err = MkTxError -> m Datum
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DatumHash -> MkTxError
DatumNotFound DatumHash
dvh) in
    (ScriptLookups a -> Map DatumHash Datum) -> m (Map DatumHash Datum)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ScriptLookups a -> Map DatumHash Datum
forall a. ScriptLookups a -> Map DatumHash Datum
slOtherData m (Map DatumHash Datum)
-> (Map DatumHash Datum -> m Datum) -> m Datum
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Datum -> (Datum -> m Datum) -> Maybe Datum -> m Datum
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Datum
err Datum -> m Datum
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Datum -> m Datum)
-> (Map DatumHash Datum -> Maybe Datum)
-> Map DatumHash Datum
-> m Datum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe Datum) (Map DatumHash Datum) (Maybe Datum)
-> Map DatumHash Datum -> Maybe Datum
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Index (Map DatumHash Datum)
-> Lens'
     (Map DatumHash Datum) (Maybe (IxValue (Map DatumHash Datum)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map DatumHash Datum)
DatumHash
dvh)

lookupMintingPolicy
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => MintingPolicyHash
    -> m (Versioned MintingPolicy)
lookupMintingPolicy :: MintingPolicyHash -> m (Versioned MintingPolicy)
lookupMintingPolicy (MintingPolicyHash BuiltinByteString
mph) = (Script -> MintingPolicy)
-> Versioned Script -> Versioned MintingPolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Script -> MintingPolicy
MintingPolicy (Versioned Script -> Versioned MintingPolicy)
-> m (Versioned Script) -> m (Versioned MintingPolicy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptHash -> m (Versioned Script)
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
ScriptHash -> m (Versioned Script)
lookupScript (BuiltinByteString -> ScriptHash
ScriptHash BuiltinByteString
mph)

lookupValidator
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => ValidatorHash
    -> m (Versioned Validator)
lookupValidator :: ValidatorHash -> m (Versioned Validator)
lookupValidator (ValidatorHash BuiltinByteString
vh) = (Script -> Validator) -> Versioned Script -> Versioned Validator
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Script -> Validator
Validator (Versioned Script -> Versioned Validator)
-> m (Versioned Script) -> m (Versioned Validator)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptHash -> m (Versioned Script)
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
ScriptHash -> m (Versioned Script)
lookupScript (BuiltinByteString -> ScriptHash
ScriptHash BuiltinByteString
vh)

lookupScript
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => ScriptHash
    -> m (Versioned Script)
lookupScript :: ScriptHash -> m (Versioned Script)
lookupScript ScriptHash
sh =
    let err :: m (Versioned Script)
err = MkTxError -> m (Versioned Script)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScriptHash -> MkTxError
ScriptHashNotFound ScriptHash
sh) in
    (ScriptLookups a -> Map ScriptHash (Versioned Script))
-> m (Map ScriptHash (Versioned Script))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ScriptLookups a -> Map ScriptHash (Versioned Script)
forall a. ScriptLookups a -> Map ScriptHash (Versioned Script)
slOtherScripts m (Map ScriptHash (Versioned Script))
-> (Map ScriptHash (Versioned Script) -> m (Versioned Script))
-> m (Versioned Script)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Versioned Script)
-> (Versioned Script -> m (Versioned Script))
-> Maybe (Versioned Script)
-> m (Versioned Script)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (Versioned Script)
err Versioned Script -> m (Versioned Script)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Versioned Script) -> m (Versioned Script))
-> (Map ScriptHash (Versioned Script) -> Maybe (Versioned Script))
-> Map ScriptHash (Versioned Script)
-> m (Versioned Script)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Maybe (Versioned Script))
  (Map ScriptHash (Versioned Script))
  (Maybe (Versioned Script))
-> Map ScriptHash (Versioned Script) -> Maybe (Versioned Script)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Index (Map ScriptHash (Versioned Script))
-> Lens'
     (Map ScriptHash (Versioned Script))
     (Maybe (IxValue (Map ScriptHash (Versioned Script))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ScriptHash (Versioned Script))
ScriptHash
sh)

lookupScriptAsReferenceScript
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => Maybe ScriptHash
    -> m ReferenceScript
lookupScriptAsReferenceScript :: Maybe ScriptHash -> m ReferenceScript
lookupScriptAsReferenceScript Maybe ScriptHash
msh = do
    Maybe (Versioned Script)
mscript <- (ScriptHash -> m (Versioned Script))
-> Maybe ScriptHash -> m (Maybe (Versioned Script))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptHash -> m (Versioned Script)
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
ScriptHash -> m (Versioned Script)
lookupScript Maybe ScriptHash
msh
    Either ToCardanoError ReferenceScript -> m ReferenceScript
forall (m :: * -> *) a.
MonadError MkTxError m =>
Either ToCardanoError a -> m a
throwToCardanoError (Either ToCardanoError ReferenceScript -> m ReferenceScript)
-> Either ToCardanoError ReferenceScript -> m ReferenceScript
forall a b. (a -> b) -> a -> b
$ Maybe (Versioned Script) -> Either ToCardanoError ReferenceScript
C.toCardanoReferenceScript Maybe (Versioned Script)
mscript

-- | Modify the 'UnbalancedTx' so that it satisfies the constraints, if
--   possible. Fails if a hash is missing from the lookups, or if an output
--   of the wrong type is spent.
processConstraint
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       , MonadState ConstraintProcessingState m
       )
    => TxConstraint
    -> m ()
processConstraint :: TxConstraint -> m ()
processConstraint = \case
    MustIncludeDatumInTxWithHash DatumHash
_ Datum
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- always succeeds
    MustIncludeDatumInTx Datum
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- always succeeds
    MustValidateInTimeRange ValidityInterval POSIXTime
timeRange -> do
        SlotRange
slotRange <-
            (ConstraintProcessingState -> SlotRange) -> m SlotRange
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ( (SlotConfig -> POSIXTimeRange -> SlotRange)
-> POSIXTimeRange -> SlotConfig -> SlotRange
forall a b c. (a -> b -> c) -> b -> a -> c
flip SlotConfig -> POSIXTimeRange -> SlotRange
posixTimeRangeToContainedSlotRange (ValidityInterval POSIXTime -> POSIXTimeRange
forall a. ValidityInterval a -> Interval a
toPlutusInterval ValidityInterval POSIXTime
timeRange)
                 (SlotConfig -> SlotRange)
-> (ConstraintProcessingState -> SlotConfig)
-> ConstraintProcessingState
-> SlotRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> SlotConfig
pSlotConfig
                 (Params -> SlotConfig)
-> (ConstraintProcessingState -> Params)
-> ConstraintProcessingState
-> SlotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintProcessingState -> Params
cpsParams
                 )
        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((SlotRange -> Identity SlotRange)
    -> UnbalancedTx -> Identity UnbalancedTx)
-> (SlotRange -> Identity SlotRange)
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> ((SlotRange -> Identity SlotRange) -> Tx -> Identity Tx)
-> (SlotRange -> Identity SlotRange)
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotRange -> Identity SlotRange) -> Tx -> Identity Tx
Lens' Tx SlotRange
Tx.validRange ((SlotRange -> Identity SlotRange)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (SlotRange -> SlotRange) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (SlotRange
slotRange SlotRange -> SlotRange -> SlotRange
forall a. MeetSemiLattice a => a -> a -> a
/\)
    MustBeSignedBy PaymentPubKeyHash
pk ->
        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Set PaymentPubKeyHash -> Identity (Set PaymentPubKeyHash))
    -> UnbalancedTx -> Identity UnbalancedTx)
-> (Set PaymentPubKeyHash -> Identity (Set PaymentPubKeyHash))
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set PaymentPubKeyHash -> Identity (Set PaymentPubKeyHash))
-> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx (Set PaymentPubKeyHash)
requiredSignatories ((Set PaymentPubKeyHash -> Identity (Set PaymentPubKeyHash))
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> Set PaymentPubKeyHash -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= PaymentPubKeyHash -> Set PaymentPubKeyHash
forall a. a -> Set a
Set.singleton PaymentPubKeyHash
pk
    MustSpendAtLeast Value
vl -> (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentInputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
required Value
vl
    MustProduceAtLeast Value
vl -> (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentOutputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
required Value
vl

    MustSpendPubKeyOutput TxOutRef
txo -> do
        DecoratedTxOut
txout <- TxOutRef -> m DecoratedTxOut
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
TxOutRef -> m DecoratedTxOut
lookupTxOutRef TxOutRef
txo
        Value
value <- m Value -> (Value -> m Value) -> Maybe Value -> m Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MkTxError -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxOutRef -> MkTxError
TxOutRefWrongType TxOutRef
txo)) Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> m Value) -> Maybe Value -> m Value
forall a b. (a -> b) -> a -> b
$ do
                       Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ APrism
  DecoratedTxOut
  DecoratedTxOut
  (PubKeyHash, Maybe StakingCredential, Value,
   Maybe (DatumHash, DatumFromQuery), Maybe (Versioned Script))
  (PubKeyHash, Maybe StakingCredential, Value,
   Maybe (DatumHash, DatumFromQuery), Maybe (Versioned Script))
-> DecoratedTxOut -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism
  DecoratedTxOut
  DecoratedTxOut
  (PubKeyHash, Maybe StakingCredential, Value,
   Maybe (DatumHash, DatumFromQuery), Maybe (Versioned Script))
  (PubKeyHash, Maybe StakingCredential, Value,
   Maybe (DatumHash, DatumFromQuery), Maybe (Versioned Script))
Prism'
  DecoratedTxOut
  (PubKeyHash, Maybe StakingCredential, Value,
   Maybe (DatumHash, DatumFromQuery), Maybe (Versioned Script))
Tx._PublicKeyDecoratedTxOut DecoratedTxOut
txout
                       Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ DecoratedTxOut
txout DecoratedTxOut -> Getting Value DecoratedTxOut Value -> Value
forall s a. s -> Getting a s a -> a
^. Getting Value DecoratedTxOut Value
Lens' DecoratedTxOut Value
Tx.decoratedTxOutValue
        -- TODO: Add the optional datum in the witness set for the pub key output
        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (([TxInput] -> Identity [TxInput])
    -> UnbalancedTx -> Identity UnbalancedTx)
-> ([TxInput] -> Identity [TxInput])
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx)
-> ([TxInput] -> Identity [TxInput])
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx
Lens' Tx [TxInput]
Tx.inputs (([TxInput] -> Identity [TxInput])
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ([TxInput] -> [TxInput]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (TxOutRef -> TxInput
Tx.pubKeyTxInput TxOutRef
txo TxInput -> [TxInput] -> [TxInput]
forall a. a -> [a] -> [a]
:)
        (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentInputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
provided Value
value

    MustSpendScriptOutput TxOutRef
txo Redeemer
red Maybe TxOutRef
mref -> do
        DecoratedTxOut
txout <- TxOutRef -> m DecoratedTxOut
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
TxOutRef -> m DecoratedTxOut
lookupTxOutRef TxOutRef
txo
        Maybe (DatumWithOrigin, Value)
mDatumAndValue <- DecoratedTxOut -> m (Maybe (DatumWithOrigin, Value))
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
DecoratedTxOut -> m (Maybe (DatumWithOrigin, Value))
resolveScriptTxOutDatumAndValue DecoratedTxOut
txout
        (DatumWithOrigin
datum, Value
value) <- m (DatumWithOrigin, Value)
-> ((DatumWithOrigin, Value) -> m (DatumWithOrigin, Value))
-> Maybe (DatumWithOrigin, Value)
-> m (DatumWithOrigin, Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MkTxError -> m (DatumWithOrigin, Value)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxOutRef -> MkTxError
TxOutRefWrongType TxOutRef
txo)) (DatumWithOrigin, Value) -> m (DatumWithOrigin, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DatumWithOrigin, Value)
mDatumAndValue
        (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentInputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
provided Value
value
        case Maybe TxOutRef
mref of
          Just TxOutRef
ref -> do
            DecoratedTxOut
refTxOut <- TxOutRef -> m DecoratedTxOut
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
TxOutRef -> m DecoratedTxOut
lookupTxOutRef TxOutRef
ref
            case DecoratedTxOut
refTxOut DecoratedTxOut
-> Getting
     (Maybe (Versioned Script))
     DecoratedTxOut
     (Maybe (Versioned Script))
-> Maybe (Versioned Script)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Versioned Script))
  DecoratedTxOut
  (Maybe (Versioned Script))
Lens' DecoratedTxOut (Maybe (Versioned Script))
Tx.decoratedTxOutReferenceScript  of
                Just Versioned Script
val -> do
                    (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (Tx -> Identity Tx)
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (Tx -> Tx) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= TxOutRef
-> Versioned TxOutRef -> Redeemer -> Maybe Datum -> Tx -> Tx
Tx.addReferenceTxInput TxOutRef
txo (TxOutRef
ref TxOutRef -> Versioned Script -> Versioned TxOutRef
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Versioned Script
val) Redeemer
red (DatumWithOrigin -> Maybe Datum
datumWitness DatumWithOrigin
datum)
                    (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (([TxInput] -> Identity [TxInput])
    -> UnbalancedTx -> Identity UnbalancedTx)
-> ([TxInput] -> Identity [TxInput])
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx)
-> ([TxInput] -> Identity [TxInput])
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx
Lens' Tx [TxInput]
Tx.referenceInputs (([TxInput] -> Identity [TxInput])
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> [TxInput] -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [TxOutRef -> TxInput
Tx.pubKeyTxInput TxOutRef
ref]
                Maybe (Versioned Script)
_        -> MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxOutRef -> MkTxError
TxOutRefNoReferenceScript TxOutRef
ref)
          Maybe TxOutRef
Nothing -> do
            Maybe (Versioned Validator)
mscriptTXO <- DecoratedTxOut -> m (Maybe (Versioned Validator))
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
DecoratedTxOut -> m (Maybe (Versioned Validator))
resolveScriptTxOutValidator DecoratedTxOut
txout
            case Maybe (Versioned Validator)
mscriptTXO of
                Just Versioned Validator
val -> do
                    (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (Tx -> Identity Tx)
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (Tx -> Tx) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= TxOutRef
-> Versioned Validator -> Redeemer -> Maybe Datum -> Tx -> Tx
Tx.addScriptTxInput TxOutRef
txo Versioned Validator
val Redeemer
red (DatumWithOrigin -> Maybe Datum
datumWitness DatumWithOrigin
datum)
                Maybe (Versioned Validator)
_             -> MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxOutRef -> MkTxError
TxOutRefWrongType TxOutRef
txo)

    MustUseOutputAsCollateral TxOutRef
txo -> do
        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (([TxInput] -> Identity [TxInput])
    -> UnbalancedTx -> Identity UnbalancedTx)
-> ([TxInput] -> Identity [TxInput])
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx)
-> ([TxInput] -> Identity [TxInput])
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx
Lens' Tx [TxInput]
Tx.collateralInputs (([TxInput] -> Identity [TxInput])
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> [TxInput] -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [TxOutRef -> TxInput
Tx.pubKeyTxInput TxOutRef
txo]
    MustReferenceOutput TxOutRef
txo -> do
        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (([TxInput] -> Identity [TxInput])
    -> UnbalancedTx -> Identity UnbalancedTx)
-> ([TxInput] -> Identity [TxInput])
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx)
-> ([TxInput] -> Identity [TxInput])
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx
Lens' Tx [TxInput]
Tx.referenceInputs (([TxInput] -> Identity [TxInput])
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> [TxInput] -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [TxOutRef -> TxInput
Tx.pubKeyTxInput TxOutRef
txo]

    MustMintValue mpsHash :: MintingPolicyHash
mpsHash@(MintingPolicyHash BuiltinByteString
mpsHashBytes) Redeemer
red TokenName
tn Integer
i Maybe TxOutRef
mref -> do
        let value :: Integer -> Value
value = CurrencySymbol -> TokenName -> Integer -> Value
Value.singleton (MintingPolicyHash -> CurrencySymbol
Value.mpsSymbol MintingPolicyHash
mpsHash) TokenName
tn
        -- If i is negative we are burning tokens. The tokens burned must
        -- be provided as an input. So we add the value burnt to
        -- 'valueSpentInputs'. If i is positive then new tokens are created
        -- which must be added to 'valueSpentOutputs'.
        if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
            then (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentInputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
provided (Integer -> Value
value (Integer -> Integer
forall a. Num a => a -> a
negate Integer
i))
            else (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentOutputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
provided (Integer -> Value
value Integer
i)

        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((MintingWitnessesMap -> Identity MintingWitnessesMap)
    -> UnbalancedTx -> Identity UnbalancedTx)
-> (MintingWitnessesMap -> Identity MintingWitnessesMap)
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> ((MintingWitnessesMap -> Identity MintingWitnessesMap)
    -> Tx -> Identity Tx)
-> (MintingWitnessesMap -> Identity MintingWitnessesMap)
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MintingWitnessesMap -> Identity MintingWitnessesMap)
-> Tx -> Identity Tx
Lens' Tx MintingWitnessesMap
Tx.mintScripts ((MintingWitnessesMap -> Identity MintingWitnessesMap)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (MintingWitnessesMap -> MintingWitnessesMap) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MintingPolicyHash
-> (Redeemer, Maybe (Versioned TxOutRef))
-> MintingWitnessesMap
-> MintingWitnessesMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MintingPolicyHash
mpsHash (Redeemer
red, (TxOutRef -> Language -> Versioned TxOutRef)
-> Language -> TxOutRef -> Versioned TxOutRef
forall a b c. (a -> b -> c) -> b -> a -> c
flip TxOutRef -> Language -> Versioned TxOutRef
forall script. script -> Language -> Versioned script
Versioned Language
PlutusV2 (TxOutRef -> Versioned TxOutRef)
-> Maybe TxOutRef -> Maybe (Versioned TxOutRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TxOutRef
mref)
        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Value -> Identity Value)
    -> UnbalancedTx -> Identity UnbalancedTx)
-> (Value -> Identity Value)
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> ((Value -> Identity Value) -> Tx -> Identity Tx)
-> (Value -> Identity Value)
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Identity Value) -> Tx -> Identity Tx
Lens' Tx Value
Tx.mint ((Value -> Identity Value)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> Value -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Integer -> Value
value Integer
i

        case Maybe TxOutRef
mref of
            Just TxOutRef
ref -> do
                DecoratedTxOut
refTxOut <- TxOutRef -> m DecoratedTxOut
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
TxOutRef -> m DecoratedTxOut
lookupTxOutRef TxOutRef
ref
                case DecoratedTxOut
refTxOut DecoratedTxOut
-> Getting
     (First (Maybe (Versioned Script)))
     DecoratedTxOut
     (Maybe (Versioned Script))
-> Maybe (Maybe (Versioned Script))
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First (Maybe (Versioned Script)))
  DecoratedTxOut
  (Maybe (Versioned Script))
Lens' DecoratedTxOut (Maybe (Versioned Script))
decoratedTxOutReferenceScript of
                    Just Maybe (Versioned Script)
_ -> (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (([TxInput] -> Identity [TxInput])
    -> UnbalancedTx -> Identity UnbalancedTx)
-> ([TxInput] -> Identity [TxInput])
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx)
-> ([TxInput] -> Identity [TxInput])
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxInput] -> Identity [TxInput]) -> Tx -> Identity Tx
Lens' Tx [TxInput]
Tx.referenceInputs (([TxInput] -> Identity [TxInput])
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> [TxInput] -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [TxOutRef -> TxInput
Tx.pubKeyTxInput TxOutRef
ref]
                    Maybe (Maybe (Versioned Script))
_      -> MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxOutRef -> MkTxError
TxOutRefNoReferenceScript TxOutRef
ref)
            Maybe TxOutRef
Nothing -> do
                Versioned MintingPolicy
mintingPolicyScript <- MintingPolicyHash -> m (Versioned MintingPolicy)
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
MintingPolicyHash -> m (Versioned MintingPolicy)
lookupMintingPolicy MintingPolicyHash
mpsHash
                (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Map ScriptHash (Versioned Script)
     -> Identity (Map ScriptHash (Versioned Script)))
    -> UnbalancedTx -> Identity UnbalancedTx)
-> (Map ScriptHash (Versioned Script)
    -> Identity (Map ScriptHash (Versioned Script)))
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> ((Map ScriptHash (Versioned Script)
     -> Identity (Map ScriptHash (Versioned Script)))
    -> Tx -> Identity Tx)
-> (Map ScriptHash (Versioned Script)
    -> Identity (Map ScriptHash (Versioned Script)))
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Versioned Script)
 -> Identity (Map ScriptHash (Versioned Script)))
-> Tx -> Identity Tx
Lens' Tx (Map ScriptHash (Versioned Script))
Tx.scriptWitnesses ((Map ScriptHash (Versioned Script)
  -> Identity (Map ScriptHash (Versioned Script)))
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (Map ScriptHash (Versioned Script)
    -> Map ScriptHash (Versioned Script))
-> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ScriptHash
-> Versioned Script
-> Map ScriptHash (Versioned Script)
-> Map ScriptHash (Versioned Script)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (BuiltinByteString -> ScriptHash
ScriptHash BuiltinByteString
mpsHashBytes) ((MintingPolicy -> Script)
-> Versioned MintingPolicy -> Versioned Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MintingPolicy -> Script
getMintingPolicy Versioned MintingPolicy
mintingPolicyScript)


    MustPayToAddress Address
addr Maybe (TxOutDatum Datum)
mdv Maybe ScriptHash
refScriptHashM Value
vl -> do
        Maybe (TxOutDatum Datum) -> (TxOutDatum Datum -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (TxOutDatum Datum)
mdv ((TxOutDatum Datum -> m ()) -> m ())
-> (TxOutDatum Datum -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
            TxOutDatumInTx Datum
d -> do
                let theHash :: DatumHash
theHash = Datum -> DatumHash
P.datumHash Datum
d
                (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Maybe Datum -> Identity (Maybe Datum))
    -> UnbalancedTx -> Identity UnbalancedTx)
-> (Maybe Datum -> Identity (Maybe Datum))
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> ((Maybe Datum -> Identity (Maybe Datum)) -> Tx -> Identity Tx)
-> (Maybe Datum -> Identity (Maybe Datum))
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map DatumHash Datum -> Identity (Map DatumHash Datum))
-> Tx -> Identity Tx
Lens' Tx (Map DatumHash Datum)
Tx.datumWitnesses ((Map DatumHash Datum -> Identity (Map DatumHash Datum))
 -> Tx -> Identity Tx)
-> ((Maybe Datum -> Identity (Maybe Datum))
    -> Map DatumHash Datum -> Identity (Map DatumHash Datum))
-> (Maybe Datum -> Identity (Maybe Datum))
-> Tx
-> Identity Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map DatumHash Datum)
-> Lens'
     (Map DatumHash Datum) (Maybe (IxValue (Map DatumHash Datum)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map DatumHash Datum)
DatumHash
theHash ((Maybe Datum -> Identity (Maybe Datum))
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> Maybe Datum -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Datum -> Maybe Datum
forall a. a -> Maybe a
Just Datum
d
            TxOutDatum Datum
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        ReferenceScript
refScript <- Maybe ScriptHash -> m ReferenceScript
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
Maybe ScriptHash -> m ReferenceScript
lookupScriptAsReferenceScript Maybe ScriptHash
refScriptHashM
        TxOut
txOut <- Address
-> Value -> Maybe (TxOutDatum Datum) -> ReferenceScript -> m TxOut
forall (m :: * -> *).
(MonadState ConstraintProcessingState m, MonadError MkTxError m) =>
Address
-> Value -> Maybe (TxOutDatum Datum) -> ReferenceScript -> m TxOut
mkCardanoTxOut Address
addr Value
vl Maybe (TxOutDatum Datum)
mdv ReferenceScript
refScript
        (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (([TxOut] -> Identity [TxOut])
    -> UnbalancedTx -> Identity UnbalancedTx)
-> ([TxOut] -> Identity [TxOut])
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (([TxOut] -> Identity [TxOut]) -> Tx -> Identity Tx)
-> ([TxOut] -> Identity [TxOut])
-> UnbalancedTx
-> Identity UnbalancedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxOut] -> Identity [TxOut]) -> Tx -> Identity Tx
Lens' Tx [TxOut]
Tx.outputs (([TxOut] -> Identity [TxOut])
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> [TxOut] -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [TxOut
txOut]

        (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentOutputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
provided Value
vl

    MustSatisfyAnyOf [[TxConstraint]]
xs -> do
        ConstraintProcessingState
s <- m ConstraintProcessingState
forall s (m :: * -> *). MonadState s m => m s
get
        let tryNext :: [[TxConstraint]] -> m ()
tryNext [] =
                MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MkTxError
CannotSatisfyAny
            tryNext ([TxConstraint]
hs:[[TxConstraint]]
qs) = do
                (TxConstraint -> m ()) -> [TxConstraint] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TxConstraint -> m ()
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m,
 MonadState ConstraintProcessingState m) =>
TxConstraint -> m ()
processConstraint [TxConstraint]
hs m () -> (MkTxError -> m ()) -> m ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` m () -> MkTxError -> m ()
forall a b. a -> b -> a
const (ConstraintProcessingState -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConstraintProcessingState
s m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [[TxConstraint]] -> m ()
tryNext [[TxConstraint]]
qs)
        [[TxConstraint]] -> m ()
tryNext [[TxConstraint]]
xs

processConstraintFun
    :: ( MonadReader (ScriptLookups a) m
        , MonadError MkTxError m
        , MonadState ConstraintProcessingState m
        )
    => TxConstraintFun
    -> m ()
processConstraintFun :: TxConstraintFun -> m ()
processConstraintFun = \case
    MustSpendScriptOutputWithMatchingDatumAndValue ValidatorHash
vh Datum -> Bool
datumPred Value -> Bool
valuePred Redeemer
red -> do
        ScriptLookups{Map TxOutRef DecoratedTxOut
slTxOutputs :: Map TxOutRef DecoratedTxOut
slTxOutputs :: forall a. ScriptLookups a -> Map TxOutRef DecoratedTxOut
slTxOutputs} <- m (ScriptLookups a)
forall r (m :: * -> *). MonadReader r m => m r
ask
        -- TODO: Need to precalculate the validator hash or else this won't work
        -- with PlutusV2 validator. This means changing `DecoratedTxOut` to
        -- include the hash.
        let matches :: Maybe (Versioned Validator, DatumWithOrigin, Value) -> Bool
matches (Just (Versioned Validator
_, DatumWithOrigin
d, Value
value)) = Datum -> Bool
datumPred (DatumWithOrigin -> Datum
getDatum DatumWithOrigin
d) Bool -> Bool -> Bool
&& Value -> Bool
valuePred Value
value
            matches Maybe (Versioned Validator, DatumWithOrigin, Value)
Nothing              = Bool
False

        [(TxOutRef, Maybe (Versioned Validator, DatumWithOrigin, Value))]
opts <- (Map TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))
 -> [(TxOutRef,
      Maybe (Versioned Validator, DatumWithOrigin, Value))])
-> m (Map
        TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value)))
-> m [(TxOutRef,
       Maybe (Versioned Validator, DatumWithOrigin, Value))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))
-> [(TxOutRef,
     Maybe (Versioned Validator, DatumWithOrigin, Value))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))
 -> [(TxOutRef,
      Maybe (Versioned Validator, DatumWithOrigin, Value))])
-> (Map
      TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))
    -> Map
         TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value)))
-> Map
     TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))
-> [(TxOutRef,
     Maybe (Versioned Validator, DatumWithOrigin, Value))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Versioned Validator, DatumWithOrigin, Value) -> Bool)
-> Map
     TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))
-> Map
     TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Maybe (Versioned Validator, DatumWithOrigin, Value) -> Bool
matches)
                (m (Map
      TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value)))
 -> m [(TxOutRef,
        Maybe (Versioned Validator, DatumWithOrigin, Value))])
-> m (Map
        TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value)))
-> m [(TxOutRef,
       Maybe (Versioned Validator, DatumWithOrigin, Value))]
forall a b. (a -> b) -> a -> b
$ (DecoratedTxOut
 -> m (Maybe (Versioned Validator, DatumWithOrigin, Value)))
-> Map TxOutRef DecoratedTxOut
-> m (Map
        TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DecoratedTxOut
-> m (Maybe (Versioned Validator, DatumWithOrigin, Value))
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
DecoratedTxOut
-> m (Maybe (Versioned Validator, DatumWithOrigin, Value))
resolveScriptTxOut
                (Map TxOutRef DecoratedTxOut
 -> m (Map
         TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value))))
-> Map TxOutRef DecoratedTxOut
-> m (Map
        TxOutRef (Maybe (Versioned Validator, DatumWithOrigin, Value)))
forall a b. (a -> b) -> a -> b
$ (DecoratedTxOut -> Bool)
-> Map TxOutRef DecoratedTxOut -> Map TxOutRef DecoratedTxOut
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Maybe ValidatorHash -> Maybe ValidatorHash -> Bool
forall a. Eq a => a -> a -> Bool
== ValidatorHash -> Maybe ValidatorHash
forall a. a -> Maybe a
Just ValidatorHash
vh) (Maybe ValidatorHash -> Bool)
-> (DecoratedTxOut -> Maybe ValidatorHash)
-> DecoratedTxOut
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First ValidatorHash) DecoratedTxOut ValidatorHash
-> DecoratedTxOut -> Maybe ValidatorHash
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First ValidatorHash) DecoratedTxOut ValidatorHash
Traversal' DecoratedTxOut ValidatorHash
Tx.decoratedTxOutValidatorHash) Map TxOutRef DecoratedTxOut
slTxOutputs
        case [(TxOutRef, Maybe (Versioned Validator, DatumWithOrigin, Value))]
opts of
            [] -> MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m ()) -> MkTxError -> m ()
forall a b. (a -> b) -> a -> b
$ ValidatorHash -> MkTxError
NoMatchingOutputFound ValidatorHash
vh
            [(TxOutRef
ref, Just (Versioned Validator
validator, DatumWithOrigin
datum, Value
value))] -> do
                (UnbalancedTx -> Identity UnbalancedTx)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState UnbalancedTx
unbalancedTx ((UnbalancedTx -> Identity UnbalancedTx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ((Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx)
-> (Tx -> Identity Tx)
-> ConstraintProcessingState
-> Identity ConstraintProcessingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Identity Tx) -> UnbalancedTx -> Identity UnbalancedTx
Traversal' UnbalancedTx Tx
tx ((Tx -> Identity Tx)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> (Tx -> Tx) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= TxOutRef
-> Versioned Validator -> Redeemer -> Maybe Datum -> Tx -> Tx
Tx.addScriptTxInput TxOutRef
ref Versioned Validator
validator Redeemer
red (DatumWithOrigin -> Maybe Datum
datumWitness DatumWithOrigin
datum)
                (ValueSpentBalances -> Identity ValueSpentBalances)
-> ConstraintProcessingState -> Identity ConstraintProcessingState
Lens' ConstraintProcessingState ValueSpentBalances
valueSpentInputs ((ValueSpentBalances -> Identity ValueSpentBalances)
 -> ConstraintProcessingState -> Identity ConstraintProcessingState)
-> ValueSpentBalances -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Value -> ValueSpentBalances
provided Value
value
            [(TxOutRef, Maybe (Versioned Validator, DatumWithOrigin, Value))]
_ -> MkTxError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m ()) -> MkTxError -> m ()
forall a b. (a -> b) -> a -> b
$ ValidatorHash -> MkTxError
MultipleMatchingOutputsFound ValidatorHash
vh

data DatumWithOrigin
    = DatumInTx { DatumWithOrigin -> Datum
getDatum :: Datum }
    | DatumInline { getDatum :: Datum }

datumWitness :: DatumWithOrigin -> Maybe Datum
datumWitness :: DatumWithOrigin -> Maybe Datum
datumWitness (DatumInTx Datum
d)   = Datum -> Maybe Datum
forall a. a -> Maybe a
Just Datum
d
datumWitness (DatumInline Datum
_) = Maybe Datum
forall a. Maybe a
Nothing

resolveScriptTxOut
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => DecoratedTxOut -> m (Maybe (Versioned Validator, DatumWithOrigin, Value))
resolveScriptTxOut :: DecoratedTxOut
-> m (Maybe (Versioned Validator, DatumWithOrigin, Value))
resolveScriptTxOut DecoratedTxOut
txo = do
    Maybe (Versioned Validator)
mv <- DecoratedTxOut -> m (Maybe (Versioned Validator))
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
DecoratedTxOut -> m (Maybe (Versioned Validator))
resolveScriptTxOutValidator DecoratedTxOut
txo
    Maybe (DatumWithOrigin, Value)
mdv <- DecoratedTxOut -> m (Maybe (DatumWithOrigin, Value))
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
DecoratedTxOut -> m (Maybe (DatumWithOrigin, Value))
resolveScriptTxOutDatumAndValue DecoratedTxOut
txo
    Maybe (Versioned Validator, DatumWithOrigin, Value)
-> m (Maybe (Versioned Validator, DatumWithOrigin, Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Versioned Validator, DatumWithOrigin, Value)
 -> m (Maybe (Versioned Validator, DatumWithOrigin, Value)))
-> Maybe (Versioned Validator, DatumWithOrigin, Value)
-> m (Maybe (Versioned Validator, DatumWithOrigin, Value))
forall a b. (a -> b) -> a -> b
$ (\Versioned Validator
v (DatumWithOrigin
d, Value
value) -> (Versioned Validator
v, DatumWithOrigin
d, Value
value)) (Versioned Validator
 -> (DatumWithOrigin, Value)
 -> (Versioned Validator, DatumWithOrigin, Value))
-> Maybe (Versioned Validator)
-> Maybe
     ((DatumWithOrigin, Value)
      -> (Versioned Validator, DatumWithOrigin, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Versioned Validator)
mv Maybe
  ((DatumWithOrigin, Value)
   -> (Versioned Validator, DatumWithOrigin, Value))
-> Maybe (DatumWithOrigin, Value)
-> Maybe (Versioned Validator, DatumWithOrigin, Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (DatumWithOrigin, Value)
mdv

resolveScriptTxOutValidator
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => DecoratedTxOut -> m (Maybe (Versioned Validator))
resolveScriptTxOutValidator :: DecoratedTxOut -> m (Maybe (Versioned Validator))
resolveScriptTxOutValidator
        Tx.ScriptDecoratedTxOut
            { _decoratedTxOutValidator :: DecoratedTxOut -> Maybe (Versioned Validator)
Tx._decoratedTxOutValidator = Maybe (Versioned Validator)
v
            , _decoratedTxOutValidatorHash :: DecoratedTxOut -> ValidatorHash
Tx._decoratedTxOutValidatorHash = ValidatorHash
vh
            } = do
    -- first check in the 'DecoratedTxOut' for the validator, then
    -- look for it in the 'slOtherScripts' map.
    Versioned Validator
validator <- m (Versioned Validator)
-> (Versioned Validator -> m (Versioned Validator))
-> Maybe (Versioned Validator)
-> m (Versioned Validator)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ValidatorHash -> m (Versioned Validator)
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
ValidatorHash -> m (Versioned Validator)
lookupValidator ValidatorHash
vh) Versioned Validator -> m (Versioned Validator)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Versioned Validator)
v
    Maybe (Versioned Validator) -> m (Maybe (Versioned Validator))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Versioned Validator) -> m (Maybe (Versioned Validator)))
-> Maybe (Versioned Validator) -> m (Maybe (Versioned Validator))
forall a b. (a -> b) -> a -> b
$ Versioned Validator -> Maybe (Versioned Validator)
forall a. a -> Maybe a
Just Versioned Validator
validator
resolveScriptTxOutValidator DecoratedTxOut
_ = Maybe (Versioned Validator) -> m (Maybe (Versioned Validator))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Versioned Validator)
forall a. Maybe a
Nothing

resolveScriptTxOutDatumAndValue
    :: ( MonadReader (ScriptLookups a) m
       , MonadError MkTxError m
       )
    => DecoratedTxOut -> m (Maybe (DatumWithOrigin, Value))
resolveScriptTxOutDatumAndValue :: DecoratedTxOut -> m (Maybe (DatumWithOrigin, Value))
resolveScriptTxOutDatumAndValue
        Tx.ScriptDecoratedTxOut
            { _decoratedTxOutScriptDatum :: DecoratedTxOut -> (DatumHash, DatumFromQuery)
Tx._decoratedTxOutScriptDatum = (DatumHash
dh, DatumFromQuery
d)
            , Value
_decoratedTxOutValue :: DecoratedTxOut -> Value
_decoratedTxOutValue :: Value
Tx._decoratedTxOutValue
            } = do

    -- first check in the 'DecoratedTxOut' for the datum, then
    -- look for it in the 'slOtherData' map.
    DatumWithOrigin
datum <- case DatumFromQuery
d of
        DatumFromQuery
Tx.DatumUnknown      -> Datum -> DatumWithOrigin
DatumInTx (Datum -> DatumWithOrigin) -> m Datum -> m DatumWithOrigin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatumHash -> m Datum
forall a (m :: * -> *).
(MonadReader (ScriptLookups a) m, MonadError MkTxError m) =>
DatumHash -> m Datum
lookupDatum DatumHash
dh
        Tx.DatumInBody Datum
datum -> DatumWithOrigin -> m DatumWithOrigin
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Datum -> DatumWithOrigin
DatumInTx Datum
datum)
        Tx.DatumInline Datum
datum -> DatumWithOrigin -> m DatumWithOrigin
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Datum -> DatumWithOrigin
DatumInline Datum
datum)
    Maybe (DatumWithOrigin, Value)
-> m (Maybe (DatumWithOrigin, Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (DatumWithOrigin, Value)
 -> m (Maybe (DatumWithOrigin, Value)))
-> Maybe (DatumWithOrigin, Value)
-> m (Maybe (DatumWithOrigin, Value))
forall a b. (a -> b) -> a -> b
$ (DatumWithOrigin, Value) -> Maybe (DatumWithOrigin, Value)
forall a. a -> Maybe a
Just (DatumWithOrigin
datum, Value
_decoratedTxOutValue)
resolveScriptTxOutDatumAndValue DecoratedTxOut
_ = Maybe (DatumWithOrigin, Value)
-> m (Maybe (DatumWithOrigin, Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DatumWithOrigin, Value)
forall a. Maybe a
Nothing

throwToCardanoError :: MonadError MkTxError m => Either C.ToCardanoError a -> m a
throwToCardanoError :: Either ToCardanoError a -> m a
throwToCardanoError (Left ToCardanoError
err) = MkTxError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m a) -> MkTxError -> m a
forall a b. (a -> b) -> a -> b
$ ToCardanoError -> MkTxError
ToCardanoError ToCardanoError
err
throwToCardanoError (Right a
a)  = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

mkCardanoTxOut ::
    ( MonadState ConstraintProcessingState m
    , MonadError MkTxError m
    )
    => Address
    -> Value
    -> Maybe (TxOutDatum Datum)
    -> ReferenceScript
    -> m TxOut
mkCardanoTxOut :: Address
-> Value -> Maybe (TxOutDatum Datum) -> ReferenceScript -> m TxOut
mkCardanoTxOut Address
addr Value
value Maybe (TxOutDatum Datum)
mTxOutDatum ReferenceScript
refScript = do
  NetworkId
networkId <- (ConstraintProcessingState -> NetworkId) -> m NetworkId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((ConstraintProcessingState -> NetworkId) -> m NetworkId)
-> (ConstraintProcessingState -> NetworkId) -> m NetworkId
forall a b. (a -> b) -> a -> b
$ Params -> NetworkId
pNetworkId (Params -> NetworkId)
-> (ConstraintProcessingState -> Params)
-> ConstraintProcessingState
-> NetworkId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintProcessingState -> Params
cpsParams
  let cardanoTxOut :: Either ToCardanoError TxOut
cardanoTxOut =
          (TxOut CtxTx BabbageEra -> TxOut)
-> Either ToCardanoError (TxOut CtxTx BabbageEra)
-> Either ToCardanoError TxOut
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut CtxTx BabbageEra -> TxOut
TxOut (Either ToCardanoError (TxOut CtxTx BabbageEra)
 -> Either ToCardanoError TxOut)
-> Either ToCardanoError (TxOut CtxTx BabbageEra)
-> Either ToCardanoError TxOut
forall a b. (a -> b) -> a -> b
$
              AddressInEra BabbageEra
-> TxOutValue BabbageEra
-> TxOutDatum CtxTx BabbageEra
-> ReferenceScript
-> TxOut CtxTx BabbageEra
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
C.TxOut (AddressInEra BabbageEra
 -> TxOutValue BabbageEra
 -> TxOutDatum CtxTx BabbageEra
 -> ReferenceScript
 -> TxOut CtxTx BabbageEra)
-> Either ToCardanoError (AddressInEra BabbageEra)
-> Either
     ToCardanoError
     (TxOutValue BabbageEra
      -> TxOutDatum CtxTx BabbageEra
      -> ReferenceScript
      -> TxOut CtxTx BabbageEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> Address -> Either ToCardanoError (AddressInEra BabbageEra)
C.toCardanoAddressInEra NetworkId
networkId Address
addr
                      Either
  ToCardanoError
  (TxOutValue BabbageEra
   -> TxOutDatum CtxTx BabbageEra
   -> ReferenceScript
   -> TxOut CtxTx BabbageEra)
-> Either ToCardanoError (TxOutValue BabbageEra)
-> Either
     ToCardanoError
     (TxOutDatum CtxTx BabbageEra
      -> ReferenceScript -> TxOut CtxTx BabbageEra)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either ToCardanoError (TxOutValue BabbageEra)
C.toCardanoTxOutValue Value
value
                      Either
  ToCardanoError
  (TxOutDatum CtxTx BabbageEra
   -> ReferenceScript -> TxOut CtxTx BabbageEra)
-> Either ToCardanoError (TxOutDatum CtxTx BabbageEra)
-> Either
     ToCardanoError (ReferenceScript -> TxOut CtxTx BabbageEra)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TxOutDatum CtxTx BabbageEra
-> Either ToCardanoError (TxOutDatum CtxTx BabbageEra)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TxOutDatum Datum) -> TxOutDatum CtxTx BabbageEra
toTxOutDatum Maybe (TxOutDatum Datum)
mTxOutDatum)
                      Either ToCardanoError (ReferenceScript -> TxOut CtxTx BabbageEra)
-> Either ToCardanoError ReferenceScript
-> Either ToCardanoError (TxOut CtxTx BabbageEra)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReferenceScript -> Either ToCardanoError ReferenceScript
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReferenceScript
refScript

  case Either ToCardanoError TxOut
cardanoTxOut of
    Left ToCardanoError
err     -> MkTxError -> m TxOut
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MkTxError -> m TxOut) -> MkTxError -> m TxOut
forall a b. (a -> b) -> a -> b
$ ToCardanoError -> MkTxError
ToCardanoError ToCardanoError
err
    Right TxOut
cTxOut -> TxOut -> m TxOut
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut
cTxOut

toTxOutDatum :: Maybe (TxOutDatum Datum) -> C.TxOutDatum C.CtxTx C.BabbageEra
toTxOutDatum :: Maybe (TxOutDatum Datum) -> TxOutDatum CtxTx BabbageEra
toTxOutDatum = \case
    Maybe (TxOutDatum Datum)
Nothing                   -> TxOutDatum CtxTx BabbageEra
C.toCardanoTxOutNoDatum
    Just (TxOutDatumHash Datum
d)   -> Datum -> TxOutDatum CtxTx BabbageEra
forall ctx. Datum -> TxOutDatum ctx BabbageEra
C.toCardanoTxOutDatumHashFromDatum Datum
d
    Just (TxOutDatumInTx Datum
d)   -> Datum -> TxOutDatum CtxTx BabbageEra
C.toCardanoTxOutDatumInTx Datum
d
    Just (TxOutDatumInline Datum
d) -> Datum -> TxOutDatum CtxTx BabbageEra
C.toCardanoTxOutDatumInline Datum
d

data MkTxError =
    TypeCheckFailed Typed.ConnectionError
    | ToCardanoError C.ToCardanoError
    | TxOutRefNotFound TxOutRef
    | TxOutRefWrongType TxOutRef
    | TxOutRefNoReferenceScript TxOutRef
    | DatumNotFound DatumHash
    | DeclaredInputMismatch Value
    | DeclaredOutputMismatch Value
    | MintingPolicyNotFound MintingPolicyHash
    | ScriptHashNotFound ScriptHash
    | TypedValidatorMissing
    | DatumWrongHash DatumHash Datum
    | CannotSatisfyAny
    | NoMatchingOutputFound ValidatorHash
    | MultipleMatchingOutputsFound ValidatorHash
    | AmbiguousRedeemer TxOutRef [Redeemer]
    | AmbiguousReferenceScript TxOutRef [TxOutRef]
    deriving stock (MkTxError -> MkTxError -> Bool
(MkTxError -> MkTxError -> Bool)
-> (MkTxError -> MkTxError -> Bool) -> Eq MkTxError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MkTxError -> MkTxError -> Bool
$c/= :: MkTxError -> MkTxError -> Bool
== :: MkTxError -> MkTxError -> Bool
$c== :: MkTxError -> MkTxError -> Bool
Eq, Int -> MkTxError -> ShowS
[MkTxError] -> ShowS
MkTxError -> String
(Int -> MkTxError -> ShowS)
-> (MkTxError -> String)
-> ([MkTxError] -> ShowS)
-> Show MkTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MkTxError] -> ShowS
$cshowList :: [MkTxError] -> ShowS
show :: MkTxError -> String
$cshow :: MkTxError -> String
showsPrec :: Int -> MkTxError -> ShowS
$cshowsPrec :: Int -> MkTxError -> ShowS
Show, (forall x. MkTxError -> Rep MkTxError x)
-> (forall x. Rep MkTxError x -> MkTxError) -> Generic MkTxError
forall x. Rep MkTxError x -> MkTxError
forall x. MkTxError -> Rep MkTxError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MkTxError x -> MkTxError
$cfrom :: forall x. MkTxError -> Rep MkTxError x
Generic)
    deriving anyclass ([MkTxError] -> Encoding
[MkTxError] -> Value
MkTxError -> Encoding
MkTxError -> Value
(MkTxError -> Value)
-> (MkTxError -> Encoding)
-> ([MkTxError] -> Value)
-> ([MkTxError] -> Encoding)
-> ToJSON MkTxError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MkTxError] -> Encoding
$ctoEncodingList :: [MkTxError] -> Encoding
toJSONList :: [MkTxError] -> Value
$ctoJSONList :: [MkTxError] -> Value
toEncoding :: MkTxError -> Encoding
$ctoEncoding :: MkTxError -> Encoding
toJSON :: MkTxError -> Value
$ctoJSON :: MkTxError -> Value
ToJSON, Value -> Parser [MkTxError]
Value -> Parser MkTxError
(Value -> Parser MkTxError)
-> (Value -> Parser [MkTxError]) -> FromJSON MkTxError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MkTxError]
$cparseJSONList :: Value -> Parser [MkTxError]
parseJSON :: Value -> Parser MkTxError
$cparseJSON :: Value -> Parser MkTxError
FromJSON)
makeClassyPrisms ''MkTxError

instance Pretty MkTxError where
    pretty :: MkTxError -> Doc ann
pretty = \case
        TypeCheckFailed ConnectionError
e              -> Doc ann
"Type check failed:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ConnectionError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ConnectionError
e
        ToCardanoError ToCardanoError
e               -> Doc ann
"Cardano conversion error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ToCardanoError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ToCardanoError
e
        TxOutRefNotFound TxOutRef
t             -> Doc ann
"Tx out reference not found:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxOutRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutRef
t
        TxOutRefWrongType TxOutRef
t            -> Doc ann
"Tx out reference wrong type:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxOutRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutRef
t
        TxOutRefNoReferenceScript TxOutRef
t    -> Doc ann
"Tx out reference does not contain a reference script:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxOutRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutRef
t
        DatumNotFound DatumHash
h                -> Doc ann
"No datum with hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> DatumHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DatumHash
h Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"was found in lookups value"
        DeclaredInputMismatch Value
v        -> Doc ann
"Discrepancy of" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Value
v Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"inputs"
        DeclaredOutputMismatch Value
v       -> Doc ann
"Discrepancy of" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Value
v Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"outputs"
        MintingPolicyNotFound MintingPolicyHash
h        -> Doc ann
"No minting policy with hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MintingPolicyHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty MintingPolicyHash
h Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"was found"
        ScriptHashNotFound ScriptHash
h           -> Doc ann
"No script with hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ScriptHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ScriptHash
h Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"was found"
        MkTxError
TypedValidatorMissing          -> Doc ann
"Script instance is missing"
        DatumWrongHash DatumHash
h Datum
d             -> Doc ann
"Wrong hash for datum" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Datum -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Datum
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> DatumHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DatumHash
h
        MkTxError
CannotSatisfyAny               -> Doc ann
"Cannot satisfy any of the required constraints"
        NoMatchingOutputFound ValidatorHash
h        -> Doc ann
"No matching output found for validator hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidatorHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidatorHash
h
        MultipleMatchingOutputsFound ValidatorHash
h -> Doc ann
"Multiple matching outputs found for validator hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidatorHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidatorHash
h
        AmbiguousRedeemer TxOutRef
t [Redeemer]
rs         -> Doc ann
"Try to spend a script output" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxOutRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutRef
t
                                       Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"with different redeemers:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Redeemer] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Redeemer]
rs
        AmbiguousReferenceScript TxOutRef
t [TxOutRef]
rss -> Doc ann
"Try to spend a script output" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxOutRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutRef
t
                                       Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"with different referenceScript:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [TxOutRef] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [TxOutRef]
rss