{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE MonoLocalBinds       #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE NoImplicitPrelude    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
-- | Constraints for transactions
module Ledger.Constraints.TxConstraints where

import Data.Aeson (FromJSON, ToJSON)
import Data.Bifunctor (Bifunctor (bimap))
import Data.Map qualified as Map
import GHC.Generics (Generic)
import Prettyprinter (Pretty (pretty, prettyList), hang, viaShow, vsep, (<+>))

import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Prelude (Bool (False, True), Foldable (foldMap), Functor (fmap), Integer, JoinSemiLattice ((\/)),
                         Maybe (Just, Nothing), Monoid (mempty), Semigroup ((<>)), any, concat, foldl, map, mapMaybe,
                         not, null, ($), (.), (==), (>>=), (||))

import Ledger.Address (PaymentPubKeyHash, StakePubKeyHash)
import Plutus.V1.Ledger.Interval qualified as I
import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash, MintingPolicyHash, Redeemer, ValidatorHash, unitRedeemer)
import Plutus.V1.Ledger.Time (POSIXTimeRange)
import Plutus.V1.Ledger.Tx (TxOutRef)
import Plutus.V1.Ledger.Value (TokenName, Value, isZero)
import Plutus.V1.Ledger.Value qualified as Value

import Prelude qualified as Haskell

-- | Constraints on transactions that want to spend script outputs
data TxConstraint =
      MustHashDatum DatumHash Datum
    -- ^ The transaction's datum witnesses must contain the given 'DatumHash'
    -- and 'Datum'. Useful when you already have a 'DatumHash' and
    -- want to make sure that it is the actual hash of the 'Datum'.
    | MustIncludeDatum Datum
    -- ^ Like 'MustHashDatum', but the hash of the 'Datum' is computed automatically.
    | MustValidateIn POSIXTimeRange
    -- ^ The transaction's validity range must be set with the given 'POSIXTimeRange'.
    | MustBeSignedBy PaymentPubKeyHash
    -- ^ The transaction must add the given 'PaymentPubKeyHash' in its signatories.
    | MustSpendAtLeast Value
    -- ^ The sum of the transaction's input 'Value's must be at least as much as
    -- the given 'Value'.
    | MustProduceAtLeast Value
    -- ^ The sum of the transaction's output 'Value's must be at least as much as
    -- the given 'Value'.
    | MustSpendPubKeyOutput TxOutRef
    -- ^ The transaction must spend the given unspent transaction public key output.
    | MustSpendScriptOutput TxOutRef Redeemer
    -- ^ The transaction must spend the given unspent transaction script output.
    | MustMintValue MintingPolicyHash Redeemer TokenName Integer
    -- ^ The transaction must mint the given token and amount.
    | MustPayToPubKeyAddress PaymentPubKeyHash (Maybe StakePubKeyHash) (Maybe Datum) Value
    -- ^ The transaction must create a transaction output with a public key address.
    | MustPayToOtherScript ValidatorHash Datum Value
    -- ^ The transaction must create a transaction output with a script address.
    | MustSatisfyAnyOf [[TxConstraint]]
    deriving stock (Int -> TxConstraint -> ShowS
[TxConstraint] -> ShowS
TxConstraint -> String
(Int -> TxConstraint -> ShowS)
-> (TxConstraint -> String)
-> ([TxConstraint] -> ShowS)
-> Show TxConstraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxConstraint] -> ShowS
$cshowList :: [TxConstraint] -> ShowS
show :: TxConstraint -> String
$cshow :: TxConstraint -> String
showsPrec :: Int -> TxConstraint -> ShowS
$cshowsPrec :: Int -> TxConstraint -> ShowS
Haskell.Show, (forall x. TxConstraint -> Rep TxConstraint x)
-> (forall x. Rep TxConstraint x -> TxConstraint)
-> Generic TxConstraint
forall x. Rep TxConstraint x -> TxConstraint
forall x. TxConstraint -> Rep TxConstraint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TxConstraint x -> TxConstraint
$cfrom :: forall x. TxConstraint -> Rep TxConstraint x
Generic, TxConstraint -> TxConstraint -> Bool
(TxConstraint -> TxConstraint -> Bool)
-> (TxConstraint -> TxConstraint -> Bool) -> Eq TxConstraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxConstraint -> TxConstraint -> Bool
$c/= :: TxConstraint -> TxConstraint -> Bool
== :: TxConstraint -> TxConstraint -> Bool
$c== :: TxConstraint -> TxConstraint -> Bool
Haskell.Eq)
    deriving anyclass ([TxConstraint] -> Encoding
[TxConstraint] -> Value
TxConstraint -> Encoding
TxConstraint -> Value
(TxConstraint -> Value)
-> (TxConstraint -> Encoding)
-> ([TxConstraint] -> Value)
-> ([TxConstraint] -> Encoding)
-> ToJSON TxConstraint
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TxConstraint] -> Encoding
$ctoEncodingList :: [TxConstraint] -> Encoding
toJSONList :: [TxConstraint] -> Value
$ctoJSONList :: [TxConstraint] -> Value
toEncoding :: TxConstraint -> Encoding
$ctoEncoding :: TxConstraint -> Encoding
toJSON :: TxConstraint -> Value
$ctoJSON :: TxConstraint -> Value
ToJSON, Value -> Parser [TxConstraint]
Value -> Parser TxConstraint
(Value -> Parser TxConstraint)
-> (Value -> Parser [TxConstraint]) -> FromJSON TxConstraint
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TxConstraint]
$cparseJSONList :: Value -> Parser [TxConstraint]
parseJSON :: Value -> Parser TxConstraint
$cparseJSON :: Value -> Parser TxConstraint
FromJSON)

instance Pretty TxConstraint where
    pretty :: TxConstraint -> Doc ann
pretty = \case
        MustIncludeDatum Datum
dv ->
            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
"must include datum:", Datum -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Datum
dv]
        MustValidateIn POSIXTimeRange
range ->
            Doc ann
"must validate in:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> POSIXTimeRange -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow POSIXTimeRange
range
        MustBeSignedBy PaymentPubKeyHash
signatory ->
            Doc ann
"must be signed by:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PaymentPubKeyHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty PaymentPubKeyHash
signatory
        MustSpendAtLeast Value
vl ->
            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
"must spend at least:", Value -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Value
vl]
        MustProduceAtLeast Value
vl ->
            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
"must produce at least:", Value -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Value
vl]
        MustSpendPubKeyOutput TxOutRef
ref ->
            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
"must spend pubkey output:", TxOutRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutRef
ref]
        MustSpendScriptOutput TxOutRef
ref Redeemer
red ->
            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
"must spend script output:", TxOutRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutRef
ref, Redeemer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Redeemer
red]
        MustMintValue MintingPolicyHash
mps Redeemer
red TokenName
tn Integer
i ->
            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
"must mint value:", MintingPolicyHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty MintingPolicyHash
mps, Redeemer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Redeemer
red, TokenName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TokenName
tn Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i]
        MustPayToPubKeyAddress PaymentPubKeyHash
pkh Maybe StakePubKeyHash
skh Maybe Datum
datum Value
v ->
            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
"must pay to pubkey address:", PaymentPubKeyHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty PaymentPubKeyHash
pkh, Maybe StakePubKeyHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe StakePubKeyHash
skh, Maybe Datum -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Datum
datum, Value -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Value
v]
        MustPayToOtherScript ValidatorHash
vlh Datum
dv Value
vl ->
            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
"must pay to script:", ValidatorHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidatorHash
vlh, Datum -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Datum
dv, Value -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Value
vl]
        MustHashDatum DatumHash
dvh Datum
dv ->
            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
"must hash datum:", DatumHash -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DatumHash
dvh, Datum -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Datum
dv]
        MustSatisfyAnyOf [[TxConstraint]]
xs ->
            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
"must satisfy any of:", [[TxConstraint]] -> Doc ann
forall a ann. Pretty a => [a] -> Doc ann
prettyList [[TxConstraint]]
xs]

-- Constraint which specifies that the transaction must spend a transaction
-- output from a target script.
data ScriptInputConstraint a =
    ScriptInputConstraint
        { ScriptInputConstraint a -> a
icRedeemer :: a -- ^ The typed 'Redeemer' to be used with the target script
        , ScriptInputConstraint a -> TxOutRef
icTxOutRef :: TxOutRef -- ^ The UTXO to be spent by the target script
        } deriving stock (Int -> ScriptInputConstraint a -> ShowS
[ScriptInputConstraint a] -> ShowS
ScriptInputConstraint a -> String
(Int -> ScriptInputConstraint a -> ShowS)
-> (ScriptInputConstraint a -> String)
-> ([ScriptInputConstraint a] -> ShowS)
-> Show (ScriptInputConstraint a)
forall a. Show a => Int -> ScriptInputConstraint a -> ShowS
forall a. Show a => [ScriptInputConstraint a] -> ShowS
forall a. Show a => ScriptInputConstraint a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptInputConstraint a] -> ShowS
$cshowList :: forall a. Show a => [ScriptInputConstraint a] -> ShowS
show :: ScriptInputConstraint a -> String
$cshow :: forall a. Show a => ScriptInputConstraint a -> String
showsPrec :: Int -> ScriptInputConstraint a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ScriptInputConstraint a -> ShowS
Haskell.Show, (forall x.
 ScriptInputConstraint a -> Rep (ScriptInputConstraint a) x)
-> (forall x.
    Rep (ScriptInputConstraint a) x -> ScriptInputConstraint a)
-> Generic (ScriptInputConstraint a)
forall x.
Rep (ScriptInputConstraint a) x -> ScriptInputConstraint a
forall x.
ScriptInputConstraint a -> Rep (ScriptInputConstraint a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x.
Rep (ScriptInputConstraint a) x -> ScriptInputConstraint a
forall a x.
ScriptInputConstraint a -> Rep (ScriptInputConstraint a) x
$cto :: forall a x.
Rep (ScriptInputConstraint a) x -> ScriptInputConstraint a
$cfrom :: forall a x.
ScriptInputConstraint a -> Rep (ScriptInputConstraint a) x
Generic, a -> ScriptInputConstraint b -> ScriptInputConstraint a
(a -> b) -> ScriptInputConstraint a -> ScriptInputConstraint b
(forall a b.
 (a -> b) -> ScriptInputConstraint a -> ScriptInputConstraint b)
-> (forall a b.
    a -> ScriptInputConstraint b -> ScriptInputConstraint a)
-> Functor ScriptInputConstraint
forall a b. a -> ScriptInputConstraint b -> ScriptInputConstraint a
forall a b.
(a -> b) -> ScriptInputConstraint a -> ScriptInputConstraint b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ScriptInputConstraint b -> ScriptInputConstraint a
$c<$ :: forall a b. a -> ScriptInputConstraint b -> ScriptInputConstraint a
fmap :: (a -> b) -> ScriptInputConstraint a -> ScriptInputConstraint b
$cfmap :: forall a b.
(a -> b) -> ScriptInputConstraint a -> ScriptInputConstraint b
Haskell.Functor)

addTxIn :: TxOutRef -> i -> TxConstraints i o -> TxConstraints i o
addTxIn :: TxOutRef -> i -> TxConstraints i o -> TxConstraints i o
addTxIn TxOutRef
outRef i
red TxConstraints i o
tc =
    let ic :: ScriptInputConstraint i
ic = ScriptInputConstraint :: forall a. a -> TxOutRef -> ScriptInputConstraint a
ScriptInputConstraint{icRedeemer :: i
icRedeemer = i
red, icTxOutRef :: TxOutRef
icTxOutRef = TxOutRef
outRef}
    in TxConstraints i o
tc { txOwnInputs :: [ScriptInputConstraint i]
txOwnInputs = ScriptInputConstraint i
ic ScriptInputConstraint i
-> [ScriptInputConstraint i] -> [ScriptInputConstraint i]
forall a. a -> [a] -> [a]
: TxConstraints i o -> [ScriptInputConstraint i]
forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs TxConstraints i o
tc }

instance (Pretty a) => Pretty (ScriptInputConstraint a) where
    pretty :: ScriptInputConstraint a -> Doc ann
pretty ScriptInputConstraint{a
icRedeemer :: a
icRedeemer :: forall a. ScriptInputConstraint a -> a
icRedeemer, TxOutRef
icTxOutRef :: TxOutRef
icTxOutRef :: forall a. ScriptInputConstraint a -> TxOutRef
icTxOutRef} =
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ Doc ann
"Redeemer:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
icRedeemer
            , Doc ann
"TxOutRef:" 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
icTxOutRef
            ]

deriving anyclass instance (ToJSON a) => ToJSON (ScriptInputConstraint a)
deriving anyclass instance (FromJSON a) => FromJSON (ScriptInputConstraint a)
deriving stock instance (Haskell.Eq a) => Haskell.Eq (ScriptInputConstraint a)

-- Constraint which specifies that the transaction must produce a transaction
-- output which pays to a target script.
data ScriptOutputConstraint a =
    ScriptOutputConstraint
        { ScriptOutputConstraint a -> a
ocDatum :: a -- ^ Typed datum to be used with the target script
        , ScriptOutputConstraint a -> Value
ocValue :: Value
        } deriving stock (Int -> ScriptOutputConstraint a -> ShowS
[ScriptOutputConstraint a] -> ShowS
ScriptOutputConstraint a -> String
(Int -> ScriptOutputConstraint a -> ShowS)
-> (ScriptOutputConstraint a -> String)
-> ([ScriptOutputConstraint a] -> ShowS)
-> Show (ScriptOutputConstraint a)
forall a. Show a => Int -> ScriptOutputConstraint a -> ShowS
forall a. Show a => [ScriptOutputConstraint a] -> ShowS
forall a. Show a => ScriptOutputConstraint a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptOutputConstraint a] -> ShowS
$cshowList :: forall a. Show a => [ScriptOutputConstraint a] -> ShowS
show :: ScriptOutputConstraint a -> String
$cshow :: forall a. Show a => ScriptOutputConstraint a -> String
showsPrec :: Int -> ScriptOutputConstraint a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ScriptOutputConstraint a -> ShowS
Haskell.Show, (forall x.
 ScriptOutputConstraint a -> Rep (ScriptOutputConstraint a) x)
-> (forall x.
    Rep (ScriptOutputConstraint a) x -> ScriptOutputConstraint a)
-> Generic (ScriptOutputConstraint a)
forall x.
Rep (ScriptOutputConstraint a) x -> ScriptOutputConstraint a
forall x.
ScriptOutputConstraint a -> Rep (ScriptOutputConstraint a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x.
Rep (ScriptOutputConstraint a) x -> ScriptOutputConstraint a
forall a x.
ScriptOutputConstraint a -> Rep (ScriptOutputConstraint a) x
$cto :: forall a x.
Rep (ScriptOutputConstraint a) x -> ScriptOutputConstraint a
$cfrom :: forall a x.
ScriptOutputConstraint a -> Rep (ScriptOutputConstraint a) x
Generic, a -> ScriptOutputConstraint b -> ScriptOutputConstraint a
(a -> b) -> ScriptOutputConstraint a -> ScriptOutputConstraint b
(forall a b.
 (a -> b) -> ScriptOutputConstraint a -> ScriptOutputConstraint b)
-> (forall a b.
    a -> ScriptOutputConstraint b -> ScriptOutputConstraint a)
-> Functor ScriptOutputConstraint
forall a b.
a -> ScriptOutputConstraint b -> ScriptOutputConstraint a
forall a b.
(a -> b) -> ScriptOutputConstraint a -> ScriptOutputConstraint b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ScriptOutputConstraint b -> ScriptOutputConstraint a
$c<$ :: forall a b.
a -> ScriptOutputConstraint b -> ScriptOutputConstraint a
fmap :: (a -> b) -> ScriptOutputConstraint a -> ScriptOutputConstraint b
$cfmap :: forall a b.
(a -> b) -> ScriptOutputConstraint a -> ScriptOutputConstraint b
Haskell.Functor)

instance (Pretty a) => Pretty (ScriptOutputConstraint a) where
    pretty :: ScriptOutputConstraint a -> Doc ann
pretty ScriptOutputConstraint{a
ocDatum :: a
ocDatum :: forall a. ScriptOutputConstraint a -> a
ocDatum, Value
ocValue :: Value
ocValue :: forall a. ScriptOutputConstraint a -> Value
ocValue} =
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ Doc ann
"Datum:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
ocDatum
            , Doc ann
"Value:" 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
ocValue
            ]

deriving anyclass instance (ToJSON a) => ToJSON (ScriptOutputConstraint a)
deriving anyclass instance (FromJSON a) => FromJSON (ScriptOutputConstraint a)
deriving stock instance (Haskell.Eq a) => Haskell.Eq (ScriptOutputConstraint a)

-- | Restrictions placed on the allocation of funds to outputs of transactions.
data TxConstraints i o =
    TxConstraints
        { TxConstraints i o -> [TxConstraint]
txConstraints :: [TxConstraint]
        , TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs   :: [ScriptInputConstraint i]
        , TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs  :: [ScriptOutputConstraint o]
        }
    deriving stock (Int -> TxConstraints i o -> ShowS
[TxConstraints i o] -> ShowS
TxConstraints i o -> String
(Int -> TxConstraints i o -> ShowS)
-> (TxConstraints i o -> String)
-> ([TxConstraints i o] -> ShowS)
-> Show (TxConstraints i o)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall i o. (Show i, Show o) => Int -> TxConstraints i o -> ShowS
forall i o. (Show i, Show o) => [TxConstraints i o] -> ShowS
forall i o. (Show i, Show o) => TxConstraints i o -> String
showList :: [TxConstraints i o] -> ShowS
$cshowList :: forall i o. (Show i, Show o) => [TxConstraints i o] -> ShowS
show :: TxConstraints i o -> String
$cshow :: forall i o. (Show i, Show o) => TxConstraints i o -> String
showsPrec :: Int -> TxConstraints i o -> ShowS
$cshowsPrec :: forall i o. (Show i, Show o) => Int -> TxConstraints i o -> ShowS
Haskell.Show, (forall x. TxConstraints i o -> Rep (TxConstraints i o) x)
-> (forall x. Rep (TxConstraints i o) x -> TxConstraints i o)
-> Generic (TxConstraints i o)
forall x. Rep (TxConstraints i o) x -> TxConstraints i o
forall x. TxConstraints i o -> Rep (TxConstraints i o) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i o x. Rep (TxConstraints i o) x -> TxConstraints i o
forall i o x. TxConstraints i o -> Rep (TxConstraints i o) x
$cto :: forall i o x. Rep (TxConstraints i o) x -> TxConstraints i o
$cfrom :: forall i o x. TxConstraints i o -> Rep (TxConstraints i o) x
Generic)

instance Bifunctor TxConstraints where
    bimap :: (a -> b) -> (c -> d) -> TxConstraints a c -> TxConstraints b d
bimap a -> b
f c -> d
g TxConstraints a c
txc =
        TxConstraints a c
txc
            { txOwnInputs :: [ScriptInputConstraint b]
txOwnInputs = (ScriptInputConstraint a -> ScriptInputConstraint b)
-> [ScriptInputConstraint a] -> [ScriptInputConstraint b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Haskell.fmap ((a -> b) -> ScriptInputConstraint a -> ScriptInputConstraint b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Haskell.fmap a -> b
f) (TxConstraints a c -> [ScriptInputConstraint a]
forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs TxConstraints a c
txc)
            , txOwnOutputs :: [ScriptOutputConstraint d]
txOwnOutputs = (ScriptOutputConstraint c -> ScriptOutputConstraint d)
-> [ScriptOutputConstraint c] -> [ScriptOutputConstraint d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Haskell.fmap ((c -> d) -> ScriptOutputConstraint c -> ScriptOutputConstraint d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Haskell.fmap c -> d
g) (TxConstraints a c -> [ScriptOutputConstraint c]
forall i o. TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs TxConstraints a c
txc)
            }

type UntypedConstraints = TxConstraints PlutusTx.BuiltinData PlutusTx.BuiltinData

instance Semigroup (TxConstraints i o) where
    TxConstraints i o
l <> :: TxConstraints i o -> TxConstraints i o -> TxConstraints i o
<> TxConstraints i o
r =
        TxConstraints :: forall i o.
[TxConstraint]
-> [ScriptInputConstraint i]
-> [ScriptOutputConstraint o]
-> TxConstraints i o
TxConstraints
            { txConstraints :: [TxConstraint]
txConstraints = TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints TxConstraints i o
l [TxConstraint] -> [TxConstraint] -> [TxConstraint]
forall a. Semigroup a => a -> a -> a
<> TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints TxConstraints i o
r
            , txOwnInputs :: [ScriptInputConstraint i]
txOwnInputs = TxConstraints i o -> [ScriptInputConstraint i]
forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs TxConstraints i o
l [ScriptInputConstraint i]
-> [ScriptInputConstraint i] -> [ScriptInputConstraint i]
forall a. Semigroup a => a -> a -> a
<> TxConstraints i o -> [ScriptInputConstraint i]
forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs TxConstraints i o
r
            , txOwnOutputs :: [ScriptOutputConstraint o]
txOwnOutputs = TxConstraints i o -> [ScriptOutputConstraint o]
forall i o. TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs TxConstraints i o
l [ScriptOutputConstraint o]
-> [ScriptOutputConstraint o] -> [ScriptOutputConstraint o]
forall a. Semigroup a => a -> a -> a
<> TxConstraints i o -> [ScriptOutputConstraint o]
forall i o. TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs TxConstraints i o
r
            }

instance Haskell.Semigroup (TxConstraints i o) where
    <> :: TxConstraints i o -> TxConstraints i o -> TxConstraints i o
(<>) = TxConstraints i o -> TxConstraints i o -> TxConstraints i o
forall a. Semigroup a => a -> a -> a
(<>) -- uses PlutusTx.Semigroup instance

instance Monoid (TxConstraints i o) where
    mempty :: TxConstraints i o
mempty = [TxConstraint]
-> [ScriptInputConstraint i]
-> [ScriptOutputConstraint o]
-> TxConstraints i o
forall i o.
[TxConstraint]
-> [ScriptInputConstraint i]
-> [ScriptOutputConstraint o]
-> TxConstraints i o
TxConstraints [] [] []

instance Haskell.Monoid (TxConstraints i o) where
    mappend :: TxConstraints i o -> TxConstraints i o -> TxConstraints i o
mappend = TxConstraints i o -> TxConstraints i o -> TxConstraints i o
forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: TxConstraints i o
mempty  = TxConstraints i o
forall a. Monoid a => a
mempty

deriving anyclass instance (ToJSON i, ToJSON o) => ToJSON (TxConstraints i o)
deriving anyclass instance (FromJSON i, FromJSON o) => FromJSON (TxConstraints i o)
deriving stock instance (Haskell.Eq i, Haskell.Eq o) => Haskell.Eq (TxConstraints i o)

{-# INLINABLE singleton #-}
singleton :: TxConstraint -> TxConstraints i o
singleton :: TxConstraint -> TxConstraints i o
singleton TxConstraint
a = TxConstraints i o
forall a. Monoid a => a
mempty { txConstraints :: [TxConstraint]
txConstraints = [TxConstraint
a] }

{-# INLINABLE mustValidateIn #-}
-- | @mustValidateIn r@ requires the transaction's validity time range to be contained
--   in @r@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint sets the
-- transaction's validity time range to @r@.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that the
-- time range @r@ is entirely contained in the transaction's validity time range.
mustValidateIn :: forall i o. POSIXTimeRange -> TxConstraints i o
mustValidateIn :: POSIXTimeRange -> TxConstraints i o
mustValidateIn = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (POSIXTimeRange -> TxConstraint)
-> POSIXTimeRange
-> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTimeRange -> TxConstraint
MustValidateIn

{-# INLINABLE mustBeSignedBy #-}
-- | @mustBeSignedBy pk@ requires the transaction to be signed by the public
-- key @pk@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint adds @pk@ in the
-- transaction's public key witness set.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that @pk@
-- is part of the transaction's public key witness set.
mustBeSignedBy :: forall i o. PaymentPubKeyHash -> TxConstraints i o
mustBeSignedBy :: PaymentPubKeyHash -> TxConstraints i o
mustBeSignedBy = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (PaymentPubKeyHash -> TxConstraint)
-> PaymentPubKeyHash
-> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentPubKeyHash -> TxConstraint
MustBeSignedBy

{-# INLINABLE mustHashDatum #-}
-- | @mustHashDatum dh d@ requires the transaction to include the datum hash
-- @dh@ and actual datum @d@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint adds @dh@ and @d@
-- in the transaction's datum witness set.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that @dh@
-- and @d@ are part of the transaction's datum witness set.
mustHashDatum :: DatumHash -> Datum -> TxConstraints i o
mustHashDatum :: DatumHash -> Datum -> TxConstraints i o
mustHashDatum DatumHash
dvh = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Datum -> TxConstraint) -> Datum -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatumHash -> Datum -> TxConstraint
MustHashDatum DatumHash
dvh

{-# INLINABLE mustIncludeDatum #-}
-- | @mustIncludeDatum d@ requires the transaction to include the datum @d@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint adds @d@
-- in the transaction's datum witness set alongside it's hash
-- (which is computed automatically).
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that @d@
-- is part of the transaction's datum witness set.
mustIncludeDatum :: forall i o. Datum -> TxConstraints i o
mustIncludeDatum :: Datum -> TxConstraints i o
mustIncludeDatum = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Datum -> TxConstraint) -> Datum -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Datum -> TxConstraint
MustIncludeDatum

{-# INLINABLE mustPayToTheScript #-}
-- | @mustPayToTheScript d v@ locks the value @v@ with a script alongside a
-- datum @d@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint creates a script
-- output with @d@ and @v@ and adds @d@ in the transaction's datum witness set.
-- The script address is derived from the typed validator that is provided in
-- the 'Ledger.Constraints.OffChain.ScriptLookups' with
-- 'Ledger.Constraints.OffChain.typedValidatorLookups'.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that @d@ is
-- part of the datum witness set and that the new script transaction output with
-- @d@ and @v@ is part of the transaction's outputs.
mustPayToTheScript :: forall i o. PlutusTx.ToData o => o -> Value -> TxConstraints i o
mustPayToTheScript :: o -> Value -> TxConstraints i o
mustPayToTheScript o
dt Value
vl =
    TxConstraints :: forall i o.
[TxConstraint]
-> [ScriptInputConstraint i]
-> [ScriptOutputConstraint o]
-> TxConstraints i o
TxConstraints
        { txConstraints :: [TxConstraint]
txConstraints = [Datum -> TxConstraint
MustIncludeDatum (BuiltinData -> Datum
Datum (BuiltinData -> Datum) -> BuiltinData -> Datum
forall a b. (a -> b) -> a -> b
$ o -> BuiltinData
forall a. ToData a => a -> BuiltinData
PlutusTx.toBuiltinData o
dt)]
        , txOwnInputs :: [ScriptInputConstraint i]
txOwnInputs = []
        , txOwnOutputs :: [ScriptOutputConstraint o]
txOwnOutputs = [o -> Value -> ScriptOutputConstraint o
forall a. a -> Value -> ScriptOutputConstraint a
ScriptOutputConstraint o
dt Value
vl]
        }

{-# INLINABLE mustPayToPubKey #-}
-- | @mustPayToPubKey pkh v@ is the same as
-- 'mustPayWithDatumToPubKeyAddress', but without any staking key hash and datum.
mustPayToPubKey :: forall i o. PaymentPubKeyHash -> Value -> TxConstraints i o
mustPayToPubKey :: PaymentPubKeyHash -> Value -> TxConstraints i o
mustPayToPubKey PaymentPubKeyHash
pk = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Value -> TxConstraint) -> Value -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentPubKeyHash
-> Maybe StakePubKeyHash -> Maybe Datum -> Value -> TxConstraint
MustPayToPubKeyAddress PaymentPubKeyHash
pk Maybe StakePubKeyHash
forall a. Maybe a
Nothing Maybe Datum
forall a. Maybe a
Nothing

{-# INLINABLE mustPayToPubKeyAddress #-}
-- | @mustPayToPubKeyAddress pkh skh v@ is the same as
-- 'mustPayWithDatumToPubKeyAddress', but without any datum.
mustPayToPubKeyAddress
    :: forall i o
     . PaymentPubKeyHash
    -> StakePubKeyHash
    -> Value
    -> TxConstraints i o
mustPayToPubKeyAddress :: PaymentPubKeyHash -> StakePubKeyHash -> Value -> TxConstraints i o
mustPayToPubKeyAddress PaymentPubKeyHash
pkh StakePubKeyHash
skh =
     TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Value -> TxConstraint) -> Value -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentPubKeyHash
-> Maybe StakePubKeyHash -> Maybe Datum -> Value -> TxConstraint
MustPayToPubKeyAddress PaymentPubKeyHash
pkh (StakePubKeyHash -> Maybe StakePubKeyHash
forall a. a -> Maybe a
Just StakePubKeyHash
skh) Maybe Datum
forall a. Maybe a
Nothing

{-# INLINABLE mustPayWithDatumToPubKey #-}
-- | @mustPayWithDatumToPubKey pkh d v@ is the same as
-- 'mustPayWithDatumToPubKeyAddress', but without the staking key hash.
mustPayWithDatumToPubKey
    :: forall i o
     . PaymentPubKeyHash
    -> Datum
    -> Value
    -> TxConstraints i o
mustPayWithDatumToPubKey :: PaymentPubKeyHash -> Datum -> Value -> TxConstraints i o
mustPayWithDatumToPubKey PaymentPubKeyHash
pk Datum
datum =
    TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Value -> TxConstraint) -> Value -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentPubKeyHash
-> Maybe StakePubKeyHash -> Maybe Datum -> Value -> TxConstraint
MustPayToPubKeyAddress PaymentPubKeyHash
pk Maybe StakePubKeyHash
forall a. Maybe a
Nothing (Datum -> Maybe Datum
forall a. a -> Maybe a
Just Datum
datum)

{-# INLINABLE mustPayWithDatumToPubKeyAddress #-}
-- | @mustPayWithDatumToPubKeyAddress pkh skh d v@ locks a transaction output
-- with a public key address.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint creates a public key
-- output with @pkh@, @skh@, @d@ and @v@ and maybe adds @d@ in the transaction's
-- datum witness set.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that @d@ is
-- part of the datum witness set and that the public key transaction output with
-- @pkh@, @skh@, @d@ and @v@ is part of the transaction's outputs.
mustPayWithDatumToPubKeyAddress
    :: forall i o
     . PaymentPubKeyHash
    -> StakePubKeyHash
    -> Datum
    -> Value
    -> TxConstraints i o
mustPayWithDatumToPubKeyAddress :: PaymentPubKeyHash
-> StakePubKeyHash -> Datum -> Value -> TxConstraints i o
mustPayWithDatumToPubKeyAddress PaymentPubKeyHash
pkh StakePubKeyHash
skh Datum
datum =
    TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Value -> TxConstraint) -> Value -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentPubKeyHash
-> Maybe StakePubKeyHash -> Maybe Datum -> Value -> TxConstraint
MustPayToPubKeyAddress PaymentPubKeyHash
pkh (StakePubKeyHash -> Maybe StakePubKeyHash
forall a. a -> Maybe a
Just StakePubKeyHash
skh) (Datum -> Maybe Datum
forall a. a -> Maybe a
Just Datum
datum)

{-# INLINABLE mustPayToOtherScript #-}
-- | @mustPayToOtherScript vh d v@ locks the value @v@ with the given script
-- hash @vh@ alonside a datum @d@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint creates a script
-- output with @vh@, @d@ and @v@ and adds @d@ in the transaction's datum
-- witness set.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that @d@ is
-- part of the datum witness set and that the script transaction output with
-- @vh@, @d@ and @v@ is part of the transaction's outputs.
mustPayToOtherScript :: forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o
mustPayToOtherScript :: ValidatorHash -> Datum -> Value -> TxConstraints i o
mustPayToOtherScript ValidatorHash
vh Datum
dv Value
vl =
    TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (ValidatorHash -> Datum -> Value -> TxConstraint
MustPayToOtherScript ValidatorHash
vh Datum
dv Value
vl)
    TxConstraints i o -> TxConstraints i o -> TxConstraints i o
forall a. Semigroup a => a -> a -> a
<> TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (Datum -> TxConstraint
MustIncludeDatum Datum
dv)

{-# INLINABLE mustMintValue #-}
-- | Same as 'mustMintValueWithRedeemer', but sets the redeemer to the unit
-- redeemer.
mustMintValue :: forall i o. Value -> TxConstraints i o
mustMintValue :: Value -> TxConstraints i o
mustMintValue = Redeemer -> Value -> TxConstraints i o
forall i o. Redeemer -> Value -> TxConstraints i o
mustMintValueWithRedeemer Redeemer
unitRedeemer

{-# INLINABLE mustMintValueWithRedeemer #-}
-- | Same as 'mustMintCurrentWithRedeemer', but uses the minting policy hash,
-- token name and amount provided by 'Value'.
--
-- Note that we can derive the 'MintingPolicyHash' from the 'Value'\'s currency
-- symbol.
mustMintValueWithRedeemer :: forall i o. Redeemer -> Value -> TxConstraints i o
mustMintValueWithRedeemer :: Redeemer -> Value -> TxConstraints i o
mustMintValueWithRedeemer Redeemer
red =
    ((CurrencySymbol, Map TokenName Integer) -> TxConstraints i o)
-> [(CurrencySymbol, Map TokenName Integer)] -> TxConstraints i o
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CurrencySymbol, Map TokenName Integer) -> TxConstraints i o
valueConstraint ([(CurrencySymbol, Map TokenName Integer)] -> TxConstraints i o)
-> (Value -> [(CurrencySymbol, Map TokenName Integer)])
-> Value
-> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map CurrencySymbol (Map TokenName Integer)
-> [(CurrencySymbol, Map TokenName Integer)]
forall k v. Map k v -> [(k, v)]
AssocMap.toList (Map CurrencySymbol (Map TokenName Integer)
 -> [(CurrencySymbol, Map TokenName Integer)])
-> (Value -> Map CurrencySymbol (Map TokenName Integer))
-> Value
-> [(CurrencySymbol, Map TokenName Integer)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Map CurrencySymbol (Map TokenName Integer)
Value.getValue)
    where
        valueConstraint :: (CurrencySymbol, Map TokenName Integer) -> TxConstraints i o
valueConstraint (CurrencySymbol
currencySymbol, Map TokenName Integer
mp) =
            let hs :: MintingPolicyHash
hs = CurrencySymbol -> MintingPolicyHash
Value.currencyMPSHash CurrencySymbol
currencySymbol in
            ((TokenName, Integer) -> TxConstraints i o)
-> [(TokenName, Integer)] -> TxConstraints i o
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((TokenName -> Integer -> TxConstraints i o)
-> (TokenName, Integer) -> TxConstraints i o
forall a b c. (a -> b -> c) -> (a, b) -> c
Haskell.uncurry (MintingPolicyHash
-> Redeemer -> TokenName -> Integer -> TxConstraints i o
forall i o.
MintingPolicyHash
-> Redeemer -> TokenName -> Integer -> TxConstraints i o
mustMintCurrencyWithRedeemer MintingPolicyHash
hs Redeemer
red))
                    (Map TokenName Integer -> [(TokenName, Integer)]
forall k v. Map k v -> [(k, v)]
AssocMap.toList Map TokenName Integer
mp)

{-# INLINABLE mustMintCurrency #-}
-- | Same as 'mustMintCurrentWithRedeemer', but sets the redeemer to the unit
-- redeemer.
mustMintCurrency
    :: forall i o
     . MintingPolicyHash
    -> TokenName
    -> Integer
    -> TxConstraints i o
mustMintCurrency :: MintingPolicyHash -> TokenName -> Integer -> TxConstraints i o
mustMintCurrency MintingPolicyHash
mps = MintingPolicyHash
-> Redeemer -> TokenName -> Integer -> TxConstraints i o
forall i o.
MintingPolicyHash
-> Redeemer -> TokenName -> Integer -> TxConstraints i o
mustMintCurrencyWithRedeemer MintingPolicyHash
mps Redeemer
unitRedeemer

{-# INLINABLE mustMintCurrencyWithRedeemer #-}
-- | @mustMintCurrencyWithRedeemer mph r tn a@ creates the given amount @a@ of
-- the currency specified with @mph@, @r@ and @tn@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint mints a currency
-- using @mph@, @r@, @tn@ and @a@, adds @mph@ in the transaction's minting
-- policy witness set and adds @r@ in the transaction's redeemer witness set.
-- The minting policy must be provided in the
-- 'Ledger.Constraints.OffChain.ScriptLookups' with
-- 'Ledger.Constraints.OffChain.typedValidatorLookups' or
-- 'Ledger.Constraints.OffChain.mintingPolicy'.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that the
-- minted currenty @mph@, @tn@ and @a@ is part of the transaction's minting
-- information.
mustMintCurrencyWithRedeemer
    :: forall i o
     . MintingPolicyHash
    -> Redeemer
    -> TokenName
    -> Integer
    -> TxConstraints i o
mustMintCurrencyWithRedeemer :: MintingPolicyHash
-> Redeemer -> TokenName -> Integer -> TxConstraints i o
mustMintCurrencyWithRedeemer MintingPolicyHash
mps Redeemer
red TokenName
tn Integer
a = if Integer
a Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then TxConstraints i o
forall a. Monoid a => a
mempty else TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> TxConstraint -> TxConstraints i o
forall a b. (a -> b) -> a -> b
$ MintingPolicyHash
-> Redeemer -> TokenName -> Integer -> TxConstraint
MustMintValue MintingPolicyHash
mps Redeemer
red TokenName
tn Integer
a

{-# INLINABLE mustSpendAtLeast #-}
-- | @mustSpendAtLeast v@ requires the sum of the transaction's inputs value to
-- be at least @v@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint adds the missing
-- input value with an additionnal public key output using the public key hash
-- provided in the 'Ledger.Constraints.OffChain.ScriptLookups' with
-- 'Ledger.Constraints.OffChain.ownPaymentPubKeyHash' and optionnaly
-- 'Ledger.Constraints.OffChain.ownStakePubKeyHash'.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that the
-- sum of the transaction's inputs value to be at least @v@.
mustSpendAtLeast :: forall i o. Value -> TxConstraints i o
mustSpendAtLeast :: Value -> TxConstraints i o
mustSpendAtLeast = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Value -> TxConstraint) -> Value -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> TxConstraint
MustSpendAtLeast

{-# INLINABLE mustProduceAtLeast #-}
-- | @mustProduceAtLeast v@ requires the sum of the transaction's outputs value to
-- be at least @v@.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint adds the missing
-- output value with an additionnal public key output using the public key hash
-- provided in the 'Ledger.Constraints.OffChain.ScriptLookups' with
-- 'Ledger.Constraints.OffChain.ownPaymentPubKeyHash' and optionnaly
-- 'Ledger.Constraints.OffChain.ownStakePubKeyHash'.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that the
-- sum of the transaction's outputs value to be at least @v@.
mustProduceAtLeast :: forall i o. Value -> TxConstraints i o
mustProduceAtLeast :: Value -> TxConstraints i o
mustProduceAtLeast = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Value -> TxConstraint) -> Value -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> TxConstraint
MustProduceAtLeast

{-# INLINABLE mustSpendPubKeyOutput #-}
-- | @mustSpendPubKeyOutput utxo@ must spend the given unspent transaction public key output.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint adds @utxo@ as an
-- input to the transaction. Information about this @utxo@ must be provided in
-- the 'Ledger.Constraints.OffChain.ScriptLookups' with
-- 'Ledger.Constraints.OffChain.unspentOutputs'.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that the
-- transaction spends this @utxo@.
mustSpendPubKeyOutput :: forall i o. TxOutRef -> TxConstraints i o
mustSpendPubKeyOutput :: TxOutRef -> TxConstraints i o
mustSpendPubKeyOutput = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (TxOutRef -> TxConstraint) -> TxOutRef -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> TxConstraint
MustSpendPubKeyOutput

{-# INLINABLE mustSpendScriptOutput #-}
-- | @mustSpendScriptOutput utxo red@ must spend the given unspent transaction script output.
--
-- If used in 'Ledger.Constraints.OffChain', this constraint adds @utxo@ and
-- @red@ as an input to the transaction. Information about this @utxo@ must be
-- provided in the 'Ledger.Constraints.OffChain.ScriptLookups' with
-- 'Ledger.Constraints.OffChain.unspentOutputs'. The validator must be either provided by
-- 'Ledger.Constraints.OffChain.unspentOutputs' or through
-- 'Ledger.Constraints.OffChain.otherScript'. The datum must be either provided by
-- 'Ledger.Constraints.OffChain.unspentOutputs' or through
-- 'Ledger.Constraints.OffChain.otherData'.
--
-- If used in 'Ledger.Constraints.OnChain', this constraint verifies that the
-- transaction spends this @utxo@.
mustSpendScriptOutput :: forall i o. TxOutRef -> Redeemer -> TxConstraints i o
mustSpendScriptOutput :: TxOutRef -> Redeemer -> TxConstraints i o
mustSpendScriptOutput TxOutRef
txOutref = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> (Redeemer -> TxConstraint) -> Redeemer -> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> Redeemer -> TxConstraint
MustSpendScriptOutput TxOutRef
txOutref

{-# INLINABLE mustSatisfyAnyOf #-}
mustSatisfyAnyOf :: forall i o. [TxConstraints i o] -> TxConstraints i o
mustSatisfyAnyOf :: [TxConstraints i o] -> TxConstraints i o
mustSatisfyAnyOf = TxConstraint -> TxConstraints i o
forall i o. TxConstraint -> TxConstraints i o
singleton (TxConstraint -> TxConstraints i o)
-> ([TxConstraints i o] -> TxConstraint)
-> [TxConstraints i o]
-> TxConstraints i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TxConstraint]] -> TxConstraint
MustSatisfyAnyOf ([[TxConstraint]] -> TxConstraint)
-> ([TxConstraints i o] -> [[TxConstraint]])
-> [TxConstraints i o]
-> TxConstraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxConstraints i o -> [TxConstraint])
-> [TxConstraints i o] -> [[TxConstraint]]
forall a b. (a -> b) -> [a] -> [b]
map TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints

{-# INLINABLE isSatisfiable #-}
-- | Are the constraints satisfiable?
isSatisfiable :: forall i o. TxConstraints i o -> Bool
isSatisfiable :: TxConstraints i o -> Bool
isSatisfiable TxConstraints{[TxConstraint]
txConstraints :: [TxConstraint]
txConstraints :: forall i o. TxConstraints i o -> [TxConstraint]
txConstraints} =
    let intervals :: [POSIXTimeRange]
intervals = (TxConstraint -> Maybe POSIXTimeRange)
-> [TxConstraint] -> [POSIXTimeRange]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case { MustValidateIn POSIXTimeRange
i -> POSIXTimeRange -> Maybe POSIXTimeRange
forall a. a -> Maybe a
Just POSIXTimeRange
i; TxConstraint
_ -> Maybe POSIXTimeRange
forall a. Maybe a
Nothing }) [TxConstraint]
txConstraints
        itvl :: POSIXTimeRange
itvl = (POSIXTimeRange -> POSIXTimeRange -> POSIXTimeRange)
-> POSIXTimeRange -> [POSIXTimeRange] -> POSIXTimeRange
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl POSIXTimeRange -> POSIXTimeRange -> POSIXTimeRange
forall a. Ord a => Interval a -> Interval a -> Interval a
I.intersection POSIXTimeRange
forall a. Interval a
I.always [POSIXTimeRange]
intervals
    in Bool -> Bool
not (POSIXTimeRange -> Bool
forall a. (Enum a, Ord a) => Interval a -> Bool
I.isEmpty POSIXTimeRange
itvl)

{-# INLINABLE pubKeyPayments #-}
pubKeyPayments :: forall i o. TxConstraints i o -> [(PaymentPubKeyHash, Value)]
pubKeyPayments :: TxConstraints i o -> [(PaymentPubKeyHash, Value)]
pubKeyPayments TxConstraints{[TxConstraint]
txConstraints :: [TxConstraint]
txConstraints :: forall i o. TxConstraints i o -> [TxConstraint]
txConstraints} =
    Map PaymentPubKeyHash Value -> [(PaymentPubKeyHash, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList
    (Map PaymentPubKeyHash Value -> [(PaymentPubKeyHash, Value)])
-> Map PaymentPubKeyHash Value -> [(PaymentPubKeyHash, Value)]
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value)
-> [(PaymentPubKeyHash, Value)] -> Map PaymentPubKeyHash Value
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
(<>)
      ([TxConstraint]
txConstraints [TxConstraint]
-> (TxConstraint -> [(PaymentPubKeyHash, Value)])
-> [(PaymentPubKeyHash, Value)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case { MustPayToPubKeyAddress PaymentPubKeyHash
pk Maybe StakePubKeyHash
_ Maybe Datum
_ Value
vl -> [(PaymentPubKeyHash
pk, Value
vl)]; TxConstraint
_ -> [] })

-- | The minimum 'Value' that satisfies all 'MustSpendAtLeast' constraints
{-# INLINABLE mustSpendAtLeastTotal #-}
mustSpendAtLeastTotal :: forall i o. TxConstraints i o -> Value
mustSpendAtLeastTotal :: TxConstraints i o -> Value
mustSpendAtLeastTotal = (Value -> Value -> Value) -> Value -> [Value] -> Value
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Value -> Value -> Value
forall a. JoinSemiLattice a => a -> a -> a
(\/) Value
forall a. Monoid a => a
mempty ([Value] -> Value)
-> (TxConstraints i o -> [Value]) -> TxConstraints i o -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxConstraint -> Value) -> [TxConstraint] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxConstraint -> Value
f ([TxConstraint] -> [Value])
-> (TxConstraints i o -> [TxConstraint])
-> TxConstraints i o
-> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints where
    f :: TxConstraint -> Value
f (MustSpendAtLeast Value
v) = Value
v
    f TxConstraint
_                    = Value
forall a. Monoid a => a
mempty

-- | The minimum 'Value' that satisfies all 'MustProduceAtLeast' constraints
{-# INLINABLE mustProduceAtLeastTotal #-}
mustProduceAtLeastTotal :: forall i o. TxConstraints i o -> Value
mustProduceAtLeastTotal :: TxConstraints i o -> Value
mustProduceAtLeastTotal = (Value -> Value -> Value) -> Value -> [Value] -> Value
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Value -> Value -> Value
forall a. JoinSemiLattice a => a -> a -> a
(\/) Value
forall a. Monoid a => a
mempty ([Value] -> Value)
-> (TxConstraints i o -> [Value]) -> TxConstraints i o -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxConstraint -> Value) -> [TxConstraint] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxConstraint -> Value
f ([TxConstraint] -> [Value])
-> (TxConstraints i o -> [TxConstraint])
-> TxConstraints i o
-> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints where
    f :: TxConstraint -> Value
f (MustProduceAtLeast Value
v) = Value
v
    f TxConstraint
_                      = Value
forall a. Monoid a => a
mempty

{-# INLINABLE requiredSignatories #-}
requiredSignatories :: forall i o. TxConstraints i o -> [PaymentPubKeyHash]
requiredSignatories :: TxConstraints i o -> [PaymentPubKeyHash]
requiredSignatories = (TxConstraint -> [PaymentPubKeyHash])
-> [TxConstraint] -> [PaymentPubKeyHash]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxConstraint -> [PaymentPubKeyHash]
f ([TxConstraint] -> [PaymentPubKeyHash])
-> (TxConstraints i o -> [TxConstraint])
-> TxConstraints i o
-> [PaymentPubKeyHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints where
    f :: TxConstraint -> [PaymentPubKeyHash]
f (MustBeSignedBy PaymentPubKeyHash
pk) = [PaymentPubKeyHash
pk]
    f TxConstraint
_                   = []

{-# INLINABLE requiredMonetaryPolicies #-}
requiredMonetaryPolicies :: forall i o. TxConstraints i o -> [MintingPolicyHash]
requiredMonetaryPolicies :: TxConstraints i o -> [MintingPolicyHash]
requiredMonetaryPolicies = (TxConstraint -> [MintingPolicyHash])
-> [TxConstraint] -> [MintingPolicyHash]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxConstraint -> [MintingPolicyHash]
f ([TxConstraint] -> [MintingPolicyHash])
-> (TxConstraints i o -> [TxConstraint])
-> TxConstraints i o
-> [MintingPolicyHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints where
    f :: TxConstraint -> [MintingPolicyHash]
f (MustMintValue MintingPolicyHash
mps Redeemer
_ TokenName
_ Integer
_) = [MintingPolicyHash
mps]
    f TxConstraint
_                         = []

{-# INLINABLE requiredDatums #-}
requiredDatums :: forall i o. TxConstraints i o -> [Datum]
requiredDatums :: TxConstraints i o -> [Datum]
requiredDatums = (TxConstraint -> [Datum]) -> [TxConstraint] -> [Datum]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxConstraint -> [Datum]
f ([TxConstraint] -> [Datum])
-> (TxConstraints i o -> [TxConstraint])
-> TxConstraints i o
-> [Datum]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxConstraints i o -> [TxConstraint]
forall i o. TxConstraints i o -> [TxConstraint]
txConstraints where
    f :: TxConstraint -> [Datum]
f (MustIncludeDatum Datum
dv) = [Datum
dv]
    f TxConstraint
_                     = []

{-# INLINABLE modifiesUtxoSet #-}
-- | Check whether every transaction that satisfies the constraints has to
--   modify the UTXO set.
modifiesUtxoSet :: forall i o. TxConstraints i o -> Bool
modifiesUtxoSet :: TxConstraints i o -> Bool
modifiesUtxoSet TxConstraints{[TxConstraint]
txConstraints :: [TxConstraint]
txConstraints :: forall i o. TxConstraints i o -> [TxConstraint]
txConstraints, [ScriptOutputConstraint o]
txOwnOutputs :: [ScriptOutputConstraint o]
txOwnOutputs :: forall i o. TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs, [ScriptInputConstraint i]
txOwnInputs :: [ScriptInputConstraint i]
txOwnInputs :: forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs} =
    let requiresInputOutput :: TxConstraint -> Bool
requiresInputOutput = \case
            MustSpendAtLeast{}              -> Bool
True
            MustProduceAtLeast{}            -> Bool
True
            MustSpendPubKeyOutput{}         -> Bool
True
            MustSpendScriptOutput{}         -> Bool
True
            MustMintValue{}                 -> Bool
True
            MustPayToPubKeyAddress PaymentPubKeyHash
_ Maybe StakePubKeyHash
_ Maybe Datum
_ Value
vl -> Bool -> Bool
not (Value -> Bool
isZero Value
vl)
            MustPayToOtherScript ValidatorHash
_ Datum
_ Value
vl     -> Bool -> Bool
not (Value -> Bool
isZero Value
vl)
            MustSatisfyAnyOf [[TxConstraint]]
xs             -> (TxConstraint -> Bool) -> [TxConstraint] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TxConstraint -> Bool
requiresInputOutput ([TxConstraint] -> Bool) -> [TxConstraint] -> Bool
forall a b. (a -> b) -> a -> b
$ [[TxConstraint]] -> [TxConstraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TxConstraint]]
xs
            TxConstraint
_                               -> Bool
False
    in (TxConstraint -> Bool) -> [TxConstraint] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TxConstraint -> Bool
requiresInputOutput [TxConstraint]
txConstraints
        Bool -> Bool -> Bool
|| Bool -> Bool
not ([ScriptOutputConstraint o] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ScriptOutputConstraint o]
txOwnOutputs)
        Bool -> Bool -> Bool
|| Bool -> Bool
not ([ScriptInputConstraint i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ScriptInputConstraint i]
txOwnInputs)