{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE NumericUnderscores   #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns         #-}
module Convex.Utxos(
  -- * Utxo sets
  UtxoSet(..),
  fromUtxoTx,
  singleton,
  PrettyBalance(..),
  _UtxoSet,
  totalBalance,
  partition,
  onlyAda,
  onlyPubKey,
  onlyAddress,
  onlyCredential,
  onlyCredentials,
  onlyStakeCredential,
  removeUtxos,
  fromApiUtxo,
  toApiUtxo,
  selectUtxo,

  -- * Events based on transactions
  UtxoChangeEvent,
  AddUtxoEvent(..),
  RemoveUtxoEvent(..),
  extract,
  txId,

  -- * Changes to utxo sets
  UtxoChange(..),
  toUtxoChangeTx,
  fromEvent,
  PrettyUtxoChange(..),
  outputsAdded,
  outputsRemoved,
  null,
  apply,
  inv,
  extract_,
  describeChange,

  -- * Changes to addresses
  BalanceChanges(..),
  balanceChange,
  invBalanceChange,
  changeFor,
  changeForAddress
  ) where

import           Cardano.Api                   (AddressInEra, BabbageEra,
                                                Block (..), BlockInMode (..),
                                                CardanoMode, EraInMode (..),
                                                HashableScriptData,
                                                PaymentCredential,
                                                StakeCredential, Tx (..), TxId,
                                                TxIn (..), TxIx (..), UTxO (..),
                                                Value)
import qualified Cardano.Api                   as C
import           Cardano.Api.Shelley           (ExecutionUnits, TxBody (..))
import qualified Cardano.Api.Shelley           as CS
import qualified Cardano.Ledger.Alonzo.Scripts as Scripts
import           Cardano.Ledger.Alonzo.TxWits  (unRedeemers)
import qualified Cardano.Ledger.Alonzo.TxWits  as TxWitness
import qualified Cardano.Ledger.Babbage.TxBody as Babbage.TxBody
import qualified Cardano.Ledger.BaseTypes      as CT
import qualified Cardano.Ledger.Credential     as Shelley
import           Cardano.Ledger.Crypto         (StandardCrypto)
import qualified Cardano.Ledger.TxIn           as CT
import           Control.Lens                  (_1, _2, _3, makeLenses,
                                                makePrisms, over, preview, view)
import qualified Convex.Lenses                 as L
import           Data.Aeson                    (FromJSON, ToJSON)
import           Data.Bifunctor                (Bifunctor (..))
import           Data.DList                    (DList)
import qualified Data.DList                    as DList
import           Data.Map.Strict               (Map)
import qualified Data.Map.Strict               as Map
import           Data.Maybe                    (isJust, isNothing, listToMaybe,
                                                mapMaybe)
import           Data.Set                      (Set)
import qualified Data.Set                      as Set
import           Data.Text                     (Text)
import qualified Data.Text                     as Text
import           GHC.Word                      (Word64)
import           Prelude                       hiding (null)
import           Prettyprinter                 (Doc, Pretty (..), hang, parens,
                                                viaShow, vsep, (<+>))
import qualified Prettyprinter

type AddressCredential = Shelley.PaymentCredential StandardCrypto

{-| A set of unspent transaction outputs
-}
newtype UtxoSet ctx a = UtxoSet{ forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: Map C.TxIn (C.TxOut ctx C.BabbageEra, a) }
  deriving stock (UtxoSet ctx a -> UtxoSet ctx a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall ctx a. Eq a => UtxoSet ctx a -> UtxoSet ctx a -> Bool
/= :: UtxoSet ctx a -> UtxoSet ctx a -> Bool
$c/= :: forall ctx a. Eq a => UtxoSet ctx a -> UtxoSet ctx a -> Bool
== :: UtxoSet ctx a -> UtxoSet ctx a -> Bool
$c== :: forall ctx a. Eq a => UtxoSet ctx a -> UtxoSet ctx a -> Bool
Eq, Int -> UtxoSet ctx a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ctx a. Show a => Int -> UtxoSet ctx a -> ShowS
forall ctx a. Show a => [UtxoSet ctx a] -> ShowS
forall ctx a. Show a => UtxoSet ctx a -> String
showList :: [UtxoSet ctx a] -> ShowS
$cshowList :: forall ctx a. Show a => [UtxoSet ctx a] -> ShowS
show :: UtxoSet ctx a -> String
$cshow :: forall ctx a. Show a => UtxoSet ctx a -> String
showsPrec :: Int -> UtxoSet ctx a -> ShowS
$cshowsPrec :: forall ctx a. Show a => Int -> UtxoSet ctx a -> ShowS
Show, forall a b. a -> UtxoSet ctx b -> UtxoSet ctx a
forall a b. (a -> b) -> UtxoSet ctx a -> UtxoSet ctx b
forall ctx a b. a -> UtxoSet ctx b -> UtxoSet ctx a
forall ctx a b. (a -> b) -> UtxoSet ctx a -> UtxoSet ctx b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> UtxoSet ctx b -> UtxoSet ctx a
$c<$ :: forall ctx a b. a -> UtxoSet ctx b -> UtxoSet ctx a
fmap :: forall a b. (a -> b) -> UtxoSet ctx a -> UtxoSet ctx b
$cfmap :: forall ctx a b. (a -> b) -> UtxoSet ctx a -> UtxoSet ctx b
Functor)
  deriving newtype (NonEmpty (UtxoSet ctx a) -> UtxoSet ctx a
UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
forall b. Integral b => b -> UtxoSet ctx a -> UtxoSet ctx a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall ctx a. NonEmpty (UtxoSet ctx a) -> UtxoSet ctx a
forall ctx a. UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
forall ctx a b. Integral b => b -> UtxoSet ctx a -> UtxoSet ctx a
stimes :: forall b. Integral b => b -> UtxoSet ctx a -> UtxoSet ctx a
$cstimes :: forall ctx a b. Integral b => b -> UtxoSet ctx a -> UtxoSet ctx a
sconcat :: NonEmpty (UtxoSet ctx a) -> UtxoSet ctx a
$csconcat :: forall ctx a. NonEmpty (UtxoSet ctx a) -> UtxoSet ctx a
<> :: UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
$c<> :: forall ctx a. UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
Semigroup, UtxoSet ctx a
[UtxoSet ctx a] -> UtxoSet ctx a
UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall ctx a. Semigroup (UtxoSet ctx a)
forall ctx a. UtxoSet ctx a
forall ctx a. [UtxoSet ctx a] -> UtxoSet ctx a
forall ctx a. UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
mconcat :: [UtxoSet ctx a] -> UtxoSet ctx a
$cmconcat :: forall ctx a. [UtxoSet ctx a] -> UtxoSet ctx a
mappend :: UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
$cmappend :: forall ctx a. UtxoSet ctx a -> UtxoSet ctx a -> UtxoSet ctx a
mempty :: UtxoSet ctx a
$cmempty :: forall ctx a. UtxoSet ctx a
Monoid)

deriving instance (FromJSON a, FromJSON (C.TxOut ctx C.BabbageEra)) => FromJSON (UtxoSet ctx a)
deriving instance (ToJSON a, ToJSON (C.TxOut ctx C.BabbageEra)) => ToJSON (UtxoSet ctx a)

{-| A utxo set with one element
-}
singleton :: TxIn -> (C.TxOut ctx C.BabbageEra, a) -> UtxoSet ctx a
singleton :: forall ctx a. TxIn -> (TxOut ctx BabbageEra, a) -> UtxoSet ctx a
singleton TxIn
txi = forall ctx a. Map TxIn (TxOut ctx BabbageEra, a) -> UtxoSet ctx a
UtxoSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. k -> a -> Map k a
Map.singleton TxIn
txi

{-| Change the context of the outputs in this utxo set to 'CtxUTxO'
-}
fromUtxoTx :: UtxoSet C.CtxTx a -> UtxoSet C.CtxUTxO a
fromUtxoTx :: forall a. UtxoSet CtxTx a -> UtxoSet CtxUTxO a
fromUtxoTx = forall ctx a. Map TxIn (TxOut ctx BabbageEra, a) -> UtxoSet ctx a
UtxoSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall era. TxOut CtxTx era -> TxOut CtxUTxO era
C.toCtxUTxOTxOut) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos

makePrisms ''UtxoSet

{-| Convert a @cardano-api@ 'UTxO BabbageEra' to a utxo set
-}
fromApiUtxo :: UTxO BabbageEra -> UtxoSet C.CtxUTxO ()
fromApiUtxo :: UTxO BabbageEra -> UtxoSet CtxUTxO ()
fromApiUtxo (UTxO Map TxIn (TxOut CtxUTxO BabbageEra)
x) = forall ctx a. Map TxIn (TxOut ctx BabbageEra, a) -> UtxoSet ctx a
UtxoSet (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,()) Map TxIn (TxOut CtxUTxO BabbageEra)
x)

{-| Convert a utxo set to a @cardano-api@ 'UTxO BabbageEra'
-}
toApiUtxo :: UtxoSet C.CtxUTxO () -> UTxO BabbageEra
toApiUtxo :: UtxoSet CtxUTxO () -> UTxO BabbageEra
toApiUtxo (UtxoSet Map TxIn (TxOut CtxUTxO BabbageEra, ())
s) = forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
UTxO (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Map TxIn (TxOut CtxUTxO BabbageEra, ())
s)

{-| Pick an unspent output from the 'UtxoSet', if there is one.
-}
selectUtxo :: UtxoSet ctx a -> Maybe (C.TxIn, (C.TxOut ctx C.BabbageEra, a))
selectUtxo :: forall ctx a.
UtxoSet ctx a -> Maybe (TxIn, (TxOut ctx BabbageEra, a))
selectUtxo =
  -- sorting by key is pretty much a random order
  forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos

{-| Restrict the 'UtxoSet' to outputs that only have Ada values (no native assets)
-}
onlyAda :: UtxoSet ctx a -> UtxoSet ctx a
onlyAda :: forall ctx a. UtxoSet ctx a -> UtxoSet ctx a
onlyAda =
  let flt :: (TxOut ctx BabbageEra, a) -> Bool
flt = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Lovelace
C.valueToLovelace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue)
  in forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a.
((TxOut ctx BabbageEra, a) -> Bool)
-> UtxoSet ctx a -> (UtxoSet ctx a, UtxoSet ctx a)
partition (TxOut ctx BabbageEra, a) -> Bool
flt

{-| Partition the UtxoSet according to a predicate. The first UtxoSet contains all
utxos that satisfy the predicate, the second all utxos that fail the predicate.
-}
partition :: ((C.TxOut ctx C.BabbageEra, a) -> Bool) -> UtxoSet ctx a -> (UtxoSet ctx a, UtxoSet ctx a)
partition :: forall ctx a.
((TxOut ctx BabbageEra, a) -> Bool)
-> UtxoSet ctx a -> (UtxoSet ctx a, UtxoSet ctx a)
partition (TxOut ctx BabbageEra, a) -> Bool
p (UtxoSet Map TxIn (TxOut ctx BabbageEra, a)
s) =
  forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall ctx a. Map TxIn (TxOut ctx BabbageEra, a) -> UtxoSet ctx a
UtxoSet forall ctx a. Map TxIn (TxOut ctx BabbageEra, a) -> UtxoSet ctx a
UtxoSet (forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (TxOut ctx BabbageEra, a) -> Bool
p Map TxIn (TxOut ctx BabbageEra, a)
s)

{-| Restrict the 'UtxoSet' to outputs at the address
-}
onlyAddress :: AddressInEra BabbageEra -> UtxoSet ctx a -> UtxoSet ctx a
onlyAddress :: forall ctx a.
AddressInEra BabbageEra -> UtxoSet ctx a -> UtxoSet ctx a
onlyAddress AddressInEra BabbageEra
addr =
  let flt :: (TxOut ctx BabbageEra, a) -> Bool
flt = forall a. Eq a => a -> a -> Bool
(==) AddressInEra BabbageEra
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1)
  in forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a.
((TxOut ctx BabbageEra, a) -> Bool)
-> UtxoSet ctx a -> (UtxoSet ctx a, UtxoSet ctx a)
partition (TxOut ctx BabbageEra, a) -> Bool
flt

{-| Restrict the utxo set to outputs with the given payment credential
-}
onlyCredential :: PaymentCredential -> UtxoSet ctx a -> UtxoSet ctx a
onlyCredential :: forall ctx a. PaymentCredential -> UtxoSet ctx a -> UtxoSet ctx a
onlyCredential PaymentCredential
c = forall ctx a.
Set PaymentCredential -> UtxoSet ctx a -> UtxoSet ctx a
onlyCredentials (forall a. a -> Set a
Set.singleton PaymentCredential
c)

{-| Restrict the utxo set to outputs locked by one of the given payment credentials
-}
onlyCredentials :: Set (PaymentCredential) -> UtxoSet ctx a -> UtxoSet ctx a
onlyCredentials :: forall ctx a.
Set PaymentCredential -> UtxoSet ctx a -> UtxoSet ctx a
onlyCredentials Set PaymentCredential
cs =
  let flt :: (TxOut ctx BabbageEra, a) -> Bool
flt (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PaymentCredential StandardCrypto -> PaymentCredential
CS.fromShelleyPaymentCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism'
  (AddressInEra BabbageEra)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._ShelleyAddressInBabbageEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) -> Maybe PaymentCredential
k) = case Maybe PaymentCredential
k of
        Just PaymentCredential
c -> PaymentCredential
c forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PaymentCredential
cs
        Maybe PaymentCredential
_      -> Bool
False
  in forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a.
((TxOut ctx BabbageEra, a) -> Bool)
-> UtxoSet ctx a -> (UtxoSet ctx a, UtxoSet ctx a)
partition (TxOut ctx BabbageEra, a) -> Bool
flt

{-| Restrict the utxo set to outputs with the given stake credential
-}
onlyStakeCredential :: StakeCredential -> UtxoSet ctx a -> UtxoSet ctx a
onlyStakeCredential :: forall ctx a. StakeCredential -> UtxoSet ctx a -> UtxoSet ctx a
onlyStakeCredential (StakeCredential -> StakeAddressReference
C.StakeAddressByValue -> StakeAddressReference
c) =
  let flt :: (TxOut ctx BabbageEra, a) -> Bool
flt (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StakeReference StandardCrypto -> StakeAddressReference
CS.fromShelleyStakeReference forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism'
  (AddressInEra BabbageEra)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._ShelleyAddressInBabbageEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
_3) -> Maybe StakeAddressReference
k) = Maybe StakeAddressReference
k forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just StakeAddressReference
c
  in forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a.
((TxOut ctx BabbageEra, a) -> Bool)
-> UtxoSet ctx a -> (UtxoSet ctx a, UtxoSet ctx a)
partition (TxOut ctx BabbageEra, a) -> Bool
flt

{-| Restrict the 'UtxoSet' to public key outputs
-}
onlyPubKey :: UtxoSet ctx a -> UtxoSet ctx a
onlyPubKey :: forall ctx a. UtxoSet ctx a -> UtxoSet ctx a
onlyPubKey =
  let flt :: (TxOut ctx BabbageEra, a) -> Bool
flt = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism'
  (AddressInEra BabbageEra)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._ShelleyAddressInBabbageEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism'
  (PaymentCredential StandardCrypto)
  (KeyHash 'Payment StandardCrypto)
L._ShelleyPaymentCredentialByKey)
  in forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a.
((TxOut ctx BabbageEra, a) -> Bool)
-> UtxoSet ctx a -> (UtxoSet ctx a, UtxoSet ctx a)
partition (TxOut ctx BabbageEra, a) -> Bool
flt

{-| The combined 'Value' of all outputs in the set
-}
totalBalance :: UtxoSet ctx a -> Value
totalBalance :: forall ctx a. UtxoSet ctx a -> Value
totalBalance = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos

{-| Delete some outputs from the 'UtxoSet'
-}
removeUtxos :: Set.Set C.TxIn -> UtxoSet ctx a -> UtxoSet ctx a
removeUtxos :: forall ctx a. Set TxIn -> UtxoSet ctx a -> UtxoSet ctx a
removeUtxos Set TxIn
ins = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall ctx a ctx a.
Iso
  (UtxoSet ctx a)
  (UtxoSet ctx a)
  (Map TxIn (TxOut ctx BabbageEra, a))
  (Map TxIn (TxOut ctx BabbageEra, a))
_UtxoSet (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Set TxIn
ins)

{-| A change to the UTxO set, adding and/or removing UTxOs
-}
data UtxoChange ctx a =
  UtxoChange
    { forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded   :: !(Map C.TxIn (C.TxOut ctx C.BabbageEra, a))
    , forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: !(Map C.TxIn (C.TxOut ctx C.BabbageEra, a))
    }

{-| Change the context of the outputs in this utxo change
-}
toUtxoChangeTx :: UtxoChange C.CtxTx a -> UtxoChange C.CtxUTxO a
toUtxoChangeTx :: forall a. UtxoChange CtxTx a -> UtxoChange CtxUTxO a
toUtxoChangeTx (UtxoChange Map TxIn (TxOut CtxTx BabbageEra, a)
added Map TxIn (TxOut CtxTx BabbageEra, a)
removed) =
  forall ctx a.
Map TxIn (TxOut ctx BabbageEra, a)
-> Map TxIn (TxOut ctx BabbageEra, a) -> UtxoChange ctx a
UtxoChange (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall era. TxOut CtxTx era -> TxOut CtxUTxO era
C.toCtxUTxOTxOut) Map TxIn (TxOut CtxTx BabbageEra, a)
added) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall era. TxOut CtxTx era -> TxOut CtxUTxO era
C.toCtxUTxOTxOut) Map TxIn (TxOut CtxTx BabbageEra, a)
removed)

makeLenses ''UtxoChange
-- TODO: change '<>' so that @x <> invert x == mempty@ and @invert x <> x == mempty@

instance Semigroup (UtxoChange ctx a) where
  UtxoChange ctx a
l <> :: UtxoChange ctx a -> UtxoChange ctx a -> UtxoChange ctx a
<> UtxoChange ctx a
r =
    UtxoChange
      { _outputsAdded :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded   = forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded UtxoChange ctx a
l forall a. Semigroup a => a -> a -> a
<> forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded UtxoChange ctx a
r
      , _outputsRemoved :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved = forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved UtxoChange ctx a
l forall a. Semigroup a => a -> a -> a
<> forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved UtxoChange ctx a
r
      }

instance Monoid (UtxoChange ctx a) where
  mempty :: UtxoChange ctx a
mempty = forall ctx a.
Map TxIn (TxOut ctx BabbageEra, a)
-> Map TxIn (TxOut ctx BabbageEra, a) -> UtxoChange ctx a
UtxoChange forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

{-| Is this the empty 'UtxoChange'?
-}
null :: UtxoChange ctx a -> Bool
null :: forall ctx a. UtxoChange ctx a -> Bool
null UtxoChange{Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded, Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved} = forall k a. Map k a -> Bool
Map.null Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved

{-| An event that caused the utxo set to change
-}
type UtxoChangeEvent a = Either (AddUtxoEvent a) (RemoveUtxoEvent a)

{-| A new tx out was added
-}
data AddUtxoEvent a =
  AddUtxoEvent
    { forall a. AddUtxoEvent a -> a
aueEvent :: !a
    , forall a. AddUtxoEvent a -> TxOut CtxTx BabbageEra
aueTxOut :: !(C.TxOut C.CtxTx C.BabbageEra)
    , forall a. AddUtxoEvent a -> TxIn
aueTxIn  :: !TxIn
    , forall a. AddUtxoEvent a -> TxId
aueTxId  :: !TxId
    , forall a. AddUtxoEvent a -> Tx BabbageEra
aueTx    :: C.Tx BabbageEra
    }

{-| A tx output was spent
-}
data RemoveUtxoEvent a =
  RemoveUtxoEvent
    { forall a. RemoveUtxoEvent a -> a
rueEvent    :: !a
    , forall a. RemoveUtxoEvent a -> TxOut CtxTx BabbageEra
rueTxOut    :: !(C.TxOut C.CtxTx C.BabbageEra)
    , forall a. RemoveUtxoEvent a -> TxIn
rueTxIn     :: !TxIn
    , forall a. RemoveUtxoEvent a -> TxId
rueTxId     :: !TxId
    -- ^ Id of the transaction that spent the output
    , forall a. RemoveUtxoEvent a -> Tx BabbageEra
rueTx       :: C.Tx BabbageEra
    -- ^ The transaction that spent the output
    , forall a.
RemoveUtxoEvent a -> Maybe (HashableScriptData, ExecutionUnits)
rueRedeemer :: Maybe (HashableScriptData, ExecutionUnits) -- fromAlonzoData
    }

{-| The 'UtxoChange' represented by the event.
-}
fromEvent :: UtxoChangeEvent a -> UtxoChange C.CtxTx a
fromEvent :: forall a. UtxoChangeEvent a -> UtxoChange CtxTx a
fromEvent = \case
  Left AddUtxoEvent{a
aueEvent :: a
aueEvent :: forall a. AddUtxoEvent a -> a
aueEvent, TxOut CtxTx BabbageEra
aueTxOut :: TxOut CtxTx BabbageEra
aueTxOut :: forall a. AddUtxoEvent a -> TxOut CtxTx BabbageEra
aueTxOut, TxIn
aueTxIn :: TxIn
aueTxIn :: forall a. AddUtxoEvent a -> TxIn
aueTxIn} ->
    let ch :: Map TxIn (TxOut CtxTx BabbageEra, a)
ch = forall k a. k -> a -> Map k a
Map.singleton TxIn
aueTxIn (TxOut CtxTx BabbageEra
aueTxOut, a
aueEvent)
    in forall ctx a.
Map TxIn (TxOut ctx BabbageEra, a)
-> Map TxIn (TxOut ctx BabbageEra, a) -> UtxoChange ctx a
UtxoChange Map TxIn (TxOut CtxTx BabbageEra, a)
ch forall a. Monoid a => a
mempty
  Right RemoveUtxoEvent{a
rueEvent :: a
rueEvent :: forall a. RemoveUtxoEvent a -> a
rueEvent, TxOut CtxTx BabbageEra
rueTxOut :: TxOut CtxTx BabbageEra
rueTxOut :: forall a. RemoveUtxoEvent a -> TxOut CtxTx BabbageEra
rueTxOut, TxIn
rueTxIn :: TxIn
rueTxIn :: forall a. RemoveUtxoEvent a -> TxIn
rueTxIn} ->
    let ch :: Map TxIn (TxOut CtxTx BabbageEra, a)
ch = forall k a. k -> a -> Map k a
Map.singleton TxIn
rueTxIn (TxOut CtxTx BabbageEra
rueTxOut, a
rueEvent)
    in forall ctx a.
Map TxIn (TxOut ctx BabbageEra, a)
-> Map TxIn (TxOut ctx BabbageEra, a) -> UtxoChange ctx a
UtxoChange forall a. Monoid a => a
mempty Map TxIn (TxOut CtxTx BabbageEra, a)
ch

{-| ID of the transaction that caused the event
-}
txId :: UtxoChangeEvent a -> TxId
txId :: forall a. UtxoChangeEvent a -> TxId
txId = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. AddUtxoEvent a -> TxId
aueTxId forall a. RemoveUtxoEvent a -> TxId
rueTxId

{-| A type capturing the effect a 'UtxoChange' has on the total balance of each address that it touches
-}
newtype BalanceChanges = BalanceChanges{BalanceChanges -> Map PaymentCredential Value
tbBalances :: Map PaymentCredential Value }
  deriving stock (BalanceChanges -> BalanceChanges -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BalanceChanges -> BalanceChanges -> Bool
$c/= :: BalanceChanges -> BalanceChanges -> Bool
== :: BalanceChanges -> BalanceChanges -> Bool
$c== :: BalanceChanges -> BalanceChanges -> Bool
Eq, Int -> BalanceChanges -> ShowS
[BalanceChanges] -> ShowS
BalanceChanges -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BalanceChanges] -> ShowS
$cshowList :: [BalanceChanges] -> ShowS
show :: BalanceChanges -> String
$cshow :: BalanceChanges -> String
showsPrec :: Int -> BalanceChanges -> ShowS
$cshowsPrec :: Int -> BalanceChanges -> ShowS
Show)

prettyAda :: C.Lovelace -> Doc ann
prettyAda :: forall ann. Lovelace -> Doc ann
prettyAda (C.Lovelace Integer
lvl) =
  let Double
ada :: Double = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
lvl forall a. Fractional a => a -> a -> a
/ Double
1_000_000
  in forall a ann. Pretty a => a -> Doc ann
pretty Double
ada

prettyPolicy :: C.PolicyId -> C.AssetName -> Doc ann
prettyPolicy :: forall ann. PolicyId -> AssetName -> Doc ann
prettyPolicy PolicyId
p AssetName
a =
  let ps :: Text
ps = forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText PolicyId
p
      x :: Text
x = Int -> Text -> Text
Text.take Int
4 Text
ps
      md :: Text
md = Int -> Text -> Text
Text.drop Int
52 Text
ps
  in forall a ann. Pretty a => a -> Doc ann
pretty Text
x forall a. Semigroup a => a -> a -> a
<> Doc ann
"..." forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
md forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow AssetName
a

instance Pretty BalanceChanges where
  pretty :: forall ann. BalanceChanges -> Doc ann
pretty (BalanceChanges Map PaymentCredential Value
mp) =
    let f :: (a, Value) -> Doc ann
f (a
paymentCredential, Value
vl) =
          forall ann. Int -> Doc ann -> Doc ann
hang Int
4 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a ann. Show a => a -> Doc ann
viaShow a
paymentCredential forall a. a -> [a] -> [a]
: forall ann. Value -> [Doc ann]
prettyValue Value
vl
    in forall ann. [Doc ann] -> Doc ann
vsep (forall {a} {ann}. Show a => (a, Value) -> Doc ann
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toAscList Map PaymentCredential Value
mp)

prettyValue :: C.Value -> [Doc ann]
prettyValue :: forall ann. Value -> [Doc ann]
prettyValue Value
vl =
  let k :: (AssetId, Quantity) -> Doc ann
k (AssetId
C.AdaAssetId, C.Quantity Integer
l)  = Doc ann
"Ada" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Lovelace -> Doc ann
prettyAda (Integer -> Lovelace
C.Lovelace Integer
l)
      k (C.AssetId PolicyId
p AssetName
n, C.Quantity Integer
q) = forall ann. PolicyId -> AssetName -> Doc ann
prettyPolicy PolicyId
p AssetName
n forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Integer
q
  in forall {ann}. (AssetId, Quantity) -> Doc ann
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> [(AssetId, Quantity)]
C.valueToList Value
vl

invBalanceChange :: BalanceChanges -> BalanceChanges
invBalanceChange :: BalanceChanges -> BalanceChanges
invBalanceChange = Map PaymentCredential Value -> BalanceChanges
BalanceChanges forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Value -> Value
C.negateValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. BalanceChanges -> Map PaymentCredential Value
tbBalances

instance Semigroup BalanceChanges where
  (BalanceChanges Map PaymentCredential Value
l) <> :: BalanceChanges -> BalanceChanges -> BalanceChanges
<> (BalanceChanges Map PaymentCredential Value
r) =
    Map PaymentCredential Value -> BalanceChanges
BalanceChanges (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) Map PaymentCredential Value
l Map PaymentCredential Value
r)

instance Monoid BalanceChanges where
  mempty :: BalanceChanges
mempty = Map PaymentCredential Value -> BalanceChanges
BalanceChanges forall a. Monoid a => a
mempty

{-| The change in currency affected by the 'UtxoChange' on each address
-}
balanceChange :: UtxoChange ctx a -> BalanceChanges
balanceChange :: forall ctx a. UtxoChange ctx a -> BalanceChanges
balanceChange UtxoChange{Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded, Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved} =
  let k :: s -> Maybe (PaymentCredential, Value)
k (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut) -> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PaymentCredential StandardCrypto -> PaymentCredential
CS.fromShelleyPaymentCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Prism' (AddressInEra BabbageEra) (Address ShelleyAddr)
L._AddressInEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso'
  (Address ShelleyAddr)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._Address forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) -> Just PaymentCredential
addr, forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Iso' (TxOutValue BabbageEra) Value
L._TxOutValue -> Value
vl, TxOutDatum ctx BabbageEra
_, ReferenceScript BabbageEra
_)) = forall a. a -> Maybe a
Just (PaymentCredential
addr, Value
vl)
      k s
_ = forall a. Maybe a
Nothing
      tv :: Map a (TxOut ctx BabbageEra, a) -> Map PaymentCredential Value
tv = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {s} {ctx}.
Field1 s s (TxOut ctx BabbageEra) (TxOut ctx BabbageEra) =>
s -> Maybe (PaymentCredential, Value)
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList

  in Map PaymentCredential Value -> BalanceChanges
BalanceChanges (forall {a}.
Map a (TxOut ctx BabbageEra, a) -> Map PaymentCredential Value
tv Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
CS.negateValue (forall {a}.
Map a (TxOut ctx BabbageEra, a) -> Map PaymentCredential Value
tv Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved))

{-| Balance change for the payment credential of a particular address. Note
that this may include the change for addresses with the same payment
credential and different staking credentials.
-}
changeForAddress :: AddressInEra C.BabbageEra -> BalanceChanges -> C.Value
changeForAddress :: AddressInEra BabbageEra -> BalanceChanges -> Value
changeForAddress (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PaymentCredential StandardCrypto -> PaymentCredential
CS.fromShelleyPaymentCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Prism' (AddressInEra BabbageEra) (Address ShelleyAddr)
L._AddressInEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso'
  (Address ShelleyAddr)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._Address forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) -> Just PaymentCredential
cred) BalanceChanges
c =
  PaymentCredential -> BalanceChanges -> Value
changeFor PaymentCredential
cred BalanceChanges
c
changeForAddress AddressInEra BabbageEra
_ BalanceChanges
_ = forall a. Monoid a => a
mempty

{-| Change for a 'PaymentCredential'
-}
changeFor :: PaymentCredential -> BalanceChanges -> C.Value
changeFor :: PaymentCredential -> BalanceChanges -> Value
changeFor PaymentCredential
cred (BalanceChanges Map PaymentCredential Value
c) = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty PaymentCredential
cred Map PaymentCredential Value
c

{-| Describe the UtxoChange
-}
describeChange :: UtxoChange ctx a -> Text
describeChange :: forall ctx a. UtxoChange ctx a -> Text
describeChange UtxoChange{Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded, Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved} =
  let tshow :: Int -> Text
tshow = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  in Int -> Text
tshow (forall k a. Map k a -> Int
Map.size Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded) forall a. Semigroup a => a -> a -> a
<> Text
" outputs added, " forall a. Semigroup a => a -> a -> a
<> Int -> Text
tshow (forall k a. Map k a -> Int
Map.size Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved) forall a. Semigroup a => a -> a -> a
<> Text
" outputs removed"

newtype PrettyUtxoChange ctx a = PrettyUtxoChange (UtxoChange ctx a)

instance Pretty a => Pretty (PrettyUtxoChange ctx a) where
  pretty :: forall ann. PrettyUtxoChange ctx a -> Doc ann
pretty (PrettyUtxoChange UtxoChange{Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded, Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved}) =
    let b :: Map TxIn (TxOut ctx BabbageEra, a) -> Value
b = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue))
        bPlus :: Value
bPlus = Map TxIn (TxOut ctx BabbageEra, a) -> Value
b Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded
        bMinus :: Value
bMinus = Value -> Value
C.negateValue (Map TxIn (TxOut ctx BabbageEra, a) -> Value
b Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved)
    in forall ann. [Doc ann] -> Doc ann
Prettyprinter.hsep forall a b. (a -> b) -> a -> b
$
        [ forall a ann. Pretty a => a -> Doc ann
pretty (forall k a. Map k a -> Int
Map.size Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded)
        , Doc ann
"outputs added"
        , forall a ann. Pretty a => a -> Doc ann
pretty (forall k a. Map k a -> Int
Map.size Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved), Doc ann
"outputs removed."]
        forall a. [a] -> [a] -> [a]
++ (forall ann. Value -> [Doc ann]
prettyValue (Value
bPlus forall a. Semigroup a => a -> a -> a
<> Value
bMinus))

newtype PrettyBalance ctx  a = PrettyBalance (UtxoSet ctx a)

instance Pretty a => Pretty (PrettyBalance ctx a) where
  pretty :: forall ann. PrettyBalance ctx a -> Doc ann
pretty (PrettyBalance UtxoSet ctx a
bal) =
    let nOutputs :: Int
nOutputs = forall k a. Map k a -> Int
Map.size (forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos UtxoSet ctx a
bal)
    in forall ann. Int -> Doc ann -> Doc ann
hang Int
4 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep
        forall a b. (a -> b) -> a -> b
$ (Doc ann
"Balance" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
parens (forall a ann. Pretty a => a -> Doc ann
pretty Int
nOutputs forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"outputs") forall a. Semigroup a => a -> a -> a
<> Doc ann
":")
        forall a. a -> [a] -> [a]
: forall ann. Value -> [Doc ann]
prettyValue (forall ctx a. UtxoSet ctx a -> Value
totalBalance UtxoSet ctx a
bal)

{-| Change the 'UtxoSet'
-}
apply :: UtxoSet ctx a -> UtxoChange ctx a -> UtxoSet ctx a
apply :: forall ctx a. UtxoSet ctx a -> UtxoChange ctx a -> UtxoSet ctx a
apply UtxoSet{Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos} UtxoChange{Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded, Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved :: forall ctx a.
UtxoChange ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved} =
  forall ctx a. Map TxIn (TxOut ctx BabbageEra, a) -> UtxoSet ctx a
UtxoSet forall a b. (a -> b) -> a -> b
$ (Map TxIn (TxOut ctx BabbageEra, a)
_utxos forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map TxIn (TxOut ctx BabbageEra, a)
_outputsAdded) forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map TxIn (TxOut ctx BabbageEra, a)
_outputsRemoved

{-| Invert a 'UtxoChange' value
-}
inv :: UtxoChange ctx a -> UtxoChange ctx a
inv :: forall ctx a. UtxoChange ctx a -> UtxoChange ctx a
inv (UtxoChange Map TxIn (TxOut ctx BabbageEra, a)
added Map TxIn (TxOut ctx BabbageEra, a)
removed) = forall ctx a.
Map TxIn (TxOut ctx BabbageEra, a)
-> Map TxIn (TxOut ctx BabbageEra, a) -> UtxoChange ctx a
UtxoChange Map TxIn (TxOut ctx BabbageEra, a)
removed Map TxIn (TxOut ctx BabbageEra, a)
added

{-| Extract from a block the UTXO changes at the given address. Returns the
'UtxoChange' itself and a set of all transactions that affected the change.
-}
extract :: (C.TxIn -> C.TxOut C.CtxTx C.BabbageEra -> Maybe a) -> Maybe AddressCredential -> UtxoSet C.CtxTx a -> BlockInMode CardanoMode -> [UtxoChangeEvent a]
extract :: forall a.
(TxIn -> TxOut CtxTx BabbageEra -> Maybe a)
-> Maybe (PaymentCredential StandardCrypto)
-> UtxoSet CtxTx a
-> BlockInMode CardanoMode
-> [UtxoChangeEvent a]
extract TxIn -> TxOut CtxTx BabbageEra -> Maybe a
ex Maybe (PaymentCredential StandardCrypto)
cred UtxoSet CtxTx a
state = forall a. DList a -> [a]
DList.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  BlockInMode Block era
block EraInMode era CardanoMode
BabbageEraInCardanoMode -> forall a.
(TxIn -> TxOut CtxTx BabbageEra -> Maybe a)
-> UtxoSet CtxTx a
-> Maybe (PaymentCredential StandardCrypto)
-> Block BabbageEra
-> DList (UtxoChangeEvent a)
extractBabbage TxIn -> TxOut CtxTx BabbageEra -> Maybe a
ex UtxoSet CtxTx a
state Maybe (PaymentCredential StandardCrypto)
cred Block era
block
  BlockInMode CardanoMode
_                                         -> forall a. Monoid a => a
mempty

{-| Extract from a block the UTXO changes at the given address
-}
extract_ :: AddressCredential -> UtxoSet C.CtxTx () -> BlockInMode CardanoMode -> UtxoChange C.CtxTx ()
extract_ :: PaymentCredential StandardCrypto
-> UtxoSet CtxTx ()
-> BlockInMode CardanoMode
-> UtxoChange CtxTx ()
extract_ PaymentCredential StandardCrypto
a UtxoSet CtxTx ()
b = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. UtxoChangeEvent a -> UtxoChange CtxTx a
fromEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(TxIn -> TxOut CtxTx BabbageEra -> Maybe a)
-> Maybe (PaymentCredential StandardCrypto)
-> UtxoSet CtxTx a
-> BlockInMode CardanoMode
-> [UtxoChangeEvent a]
extract (\TxIn
_ -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ()) (forall a. a -> Maybe a
Just PaymentCredential StandardCrypto
a) UtxoSet CtxTx ()
b

extractBabbage :: (C.TxIn -> C.TxOut C.CtxTx C.BabbageEra -> Maybe a) -> UtxoSet C.CtxTx a -> Maybe AddressCredential -> Block BabbageEra -> DList (UtxoChangeEvent a)
extractBabbage :: forall a.
(TxIn -> TxOut CtxTx BabbageEra -> Maybe a)
-> UtxoSet CtxTx a
-> Maybe (PaymentCredential StandardCrypto)
-> Block BabbageEra
-> DList (UtxoChangeEvent a)
extractBabbage TxIn -> TxOut CtxTx BabbageEra -> Maybe a
ex UtxoSet CtxTx a
state Maybe (PaymentCredential StandardCrypto)
cred (Block BlockHeader
_blockHeader [Tx BabbageEra]
txns) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a.
(TxIn -> TxOut CtxTx BabbageEra -> Maybe a)
-> UtxoSet CtxTx a
-> Maybe (PaymentCredential StandardCrypto)
-> Tx BabbageEra
-> DList (UtxoChangeEvent a)
extractBabbageTxn TxIn -> TxOut CtxTx BabbageEra -> Maybe a
ex UtxoSet CtxTx a
state Maybe (PaymentCredential StandardCrypto)
cred) [Tx BabbageEra]
txns

extractBabbageTxn :: forall a. (C.TxIn -> C.TxOut C.CtxTx C.BabbageEra -> Maybe a) -> UtxoSet C.CtxTx a -> Maybe AddressCredential -> C.Tx BabbageEra -> DList (UtxoChangeEvent a)
extractBabbageTxn :: forall a.
(TxIn -> TxOut CtxTx BabbageEra -> Maybe a)
-> UtxoSet CtxTx a
-> Maybe (PaymentCredential StandardCrypto)
-> Tx BabbageEra
-> DList (UtxoChangeEvent a)
extractBabbageTxn TxIn -> TxOut CtxTx BabbageEra -> Maybe a
ex UtxoSet{Map TxIn (TxOut CtxTx BabbageEra, a)
_utxos :: Map TxIn (TxOut CtxTx BabbageEra, a)
_utxos :: forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos} Maybe (PaymentCredential StandardCrypto)
cred theTx :: Tx BabbageEra
theTx@(Tx TxBody BabbageEra
txBody [KeyWitness BabbageEra]
_) =
  let ShelleyTxBody ShelleyBasedEra BabbageEra
_ TxBody (ShelleyLedgerEra BabbageEra)
txBody' [Script (ShelleyLedgerEra BabbageEra)]
_scripts TxBodyScriptData BabbageEra
scriptData Maybe (TxAuxData (ShelleyLedgerEra BabbageEra))
_auxiliaryData TxScriptValidity BabbageEra
_ = TxBody BabbageEra
txBody
      Babbage.TxBody.BabbageTxBody{Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
btbInputs :: forall era.
BabbageEraTxBody era =>
BabbageTxBody era -> Set (TxIn (EraCrypto era))
btbInputs :: Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
Babbage.TxBody.btbInputs} = TxBody (ShelleyLedgerEra BabbageEra)
txBody'
      txid :: TxId
txid = forall era. TxBody era -> TxId
C.getTxId TxBody BabbageEra
txBody

      allOuts :: [TxOut CtxTx BabbageEra]
allOuts = forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> TxBodyScriptData era
-> [TxOut CtxTx era]
C.fromLedgerTxOuts ShelleyBasedEra BabbageEra
C.ShelleyBasedEraBabbage TxBody (ShelleyLedgerEra BabbageEra)
txBody' TxBodyScriptData BabbageEra
scriptData

      txReds :: Map RdmrPtr (Data (BabbageEra StandardCrypto), ExUnits)
txReds = case TxBodyScriptData BabbageEra
scriptData of
              C.TxBodyScriptData ScriptDataSupportedInEra BabbageEra
C.ScriptDataInBabbageEra TxDats (ShelleyLedgerEra BabbageEra)
_ Redeemers (ShelleyLedgerEra BabbageEra)
r -> forall era.
Era era =>
Redeemers era -> Map RdmrPtr (Data era, ExUnits)
unRedeemers Redeemers (ShelleyLedgerEra BabbageEra)
r
              TxBodyScriptData BabbageEra
_                                               -> forall a. Monoid a => a
mempty

      checkInput :: (Word64, TxIn) -> Maybe (TxIn, ((C.TxOut C.CtxTx C.BabbageEra, a), Maybe (HashableScriptData, ExecutionUnits)))
      checkInput :: (Word64, TxIn)
-> Maybe
     (TxIn,
      ((TxOut CtxTx BabbageEra, a),
       Maybe (HashableScriptData, ExecutionUnits)))
checkInput (Word64
idx, TxIn
txIn) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxIn
txIn,) forall a b. (a -> b) -> a -> b
$ do
        (TxOut CtxTx BabbageEra, a)
o <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txIn Map TxIn (TxOut CtxTx BabbageEra, a)
_utxos
        let redeemer :: Maybe (HashableScriptData, ExecutionUnits)
redeemer = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall ledgerera. Data ledgerera -> HashableScriptData
CS.fromAlonzoData ExUnits -> ExecutionUnits
CS.fromAlonzoExUnits) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Tag -> Word64 -> RdmrPtr
TxWitness.RdmrPtr Tag
Scripts.Spend Word64
idx) Map RdmrPtr (Data (BabbageEra StandardCrypto), ExUnits)
txReds)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxOut CtxTx BabbageEra, a)
o, Maybe (HashableScriptData, ExecutionUnits)
redeemer)

      checkOutput :: TxIx -> C.TxOut C.CtxTx C.BabbageEra -> Maybe (TxIn, (C.TxOut C.CtxTx C.BabbageEra, a))
      checkOutput :: TxIx
-> TxOut CtxTx BabbageEra
-> Maybe (TxIn, (TxOut CtxTx BabbageEra, a))
checkOutput TxIx
txIx_ TxOut CtxTx BabbageEra
txOut
        | forall a. Maybe a -> Bool
isNothing Maybe (PaymentCredential StandardCrypto)
cred Bool -> Bool -> Bool
|| forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' (AddressInEra BabbageEra) (Address ShelleyAddr)
L._AddressInEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso'
  (Address ShelleyAddr)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._Address forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) TxOut CtxTx BabbageEra
txOut forall a. Eq a => a -> a -> Bool
== Maybe (PaymentCredential StandardCrypto)
cred =
            let txi :: TxIn
txi = TxId -> TxIx -> TxIn
TxIn TxId
txid TxIx
txIx_
            in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap  (\a
a -> (TxIn
txi, (TxOut CtxTx BabbageEra
txOut, a
a))) (TxIn -> TxOut CtxTx BabbageEra -> Maybe a
ex TxIn
txi TxOut CtxTx BabbageEra
txOut)
        | Bool
otherwise = forall a. Maybe a
Nothing

      mkI :: (TxIn, (TxOut CtxTx BabbageEra, a)) -> AddUtxoEvent a
mkI (TxIn
aueTxIn, (TxOut CtxTx BabbageEra
aueTxOut, a
aueEvent)) = AddUtxoEvent{a
aueEvent :: a
aueEvent :: a
aueEvent, TxOut CtxTx BabbageEra
aueTxOut :: TxOut CtxTx BabbageEra
aueTxOut :: TxOut CtxTx BabbageEra
aueTxOut, TxIn
aueTxIn :: TxIn
aueTxIn :: TxIn
aueTxIn, aueTxId :: TxId
aueTxId = TxId
txid, aueTx :: Tx BabbageEra
aueTx = Tx BabbageEra
theTx}

      mkO :: (TxIn,
 ((TxOut CtxTx BabbageEra, a),
  Maybe (HashableScriptData, ExecutionUnits)))
-> RemoveUtxoEvent a
mkO (TxIn
rueTxIn, ((TxOut CtxTx BabbageEra
rueTxOut, a
rueEvent), Maybe (HashableScriptData, ExecutionUnits)
rueRedeemer)) = RemoveUtxoEvent{a
rueEvent :: a
rueEvent :: a
rueEvent, TxOut CtxTx BabbageEra
rueTxOut :: TxOut CtxTx BabbageEra
rueTxOut :: TxOut CtxTx BabbageEra
rueTxOut, TxIn
rueTxIn :: TxIn
rueTxIn :: TxIn
rueTxIn, rueTxId :: TxId
rueTxId = TxId
txid, rueTx :: Tx BabbageEra
rueTx = Tx BabbageEra
theTx, Maybe (HashableScriptData, ExecutionUnits)
rueRedeemer :: Maybe (HashableScriptData, ExecutionUnits)
rueRedeemer :: Maybe (HashableScriptData, ExecutionUnits)
rueRedeemer}

      _outputsAdded :: DList (UtxoChangeEvent a)
_outputsAdded =
        forall a. [a] -> DList a
DList.fromList
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, (TxOut CtxTx BabbageEra, a)) -> AddUtxoEvent a
mkI)
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TxIx
-> TxOut CtxTx BabbageEra
-> Maybe (TxIn, (TxOut CtxTx BabbageEra, a))
checkOutput)
        forall a b. (a -> b) -> a -> b
$ (forall a b. [a] -> [b] -> [(a, b)]
zip (Word -> TxIx
TxIx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word
0..]) [TxOut CtxTx BabbageEra]
allOuts)

      _outputsRemoved :: DList (UtxoChangeEvent a)
_outputsRemoved =
        forall a. [a] -> DList a
DList.fromList
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn,
 ((TxOut CtxTx BabbageEra, a),
  Maybe (HashableScriptData, ExecutionUnits)))
-> RemoveUtxoEvent a
mkO)
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Word64, TxIn)
-> Maybe
     (TxIn,
      ((TxOut CtxTx BabbageEra, a),
       Maybe (HashableScriptData, ExecutionUnits)))
checkInput
        forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
0..] -- for redeemer pointers
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TxId -> TxIx -> TxIn
TxIn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxId StandardCrypto -> TxId
CS.fromShelleyTxId TxIx -> TxIx
txIx forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(CT.TxIn TxId StandardCrypto
i TxIx
n) -> (TxId StandardCrypto
i, TxIx
n)))
        forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
btbInputs

  in DList (UtxoChangeEvent a)
_outputsAdded forall a. Semigroup a => a -> a -> a
<> DList (UtxoChangeEvent a)
_outputsRemoved

txIx :: CT.TxIx -> TxIx
txIx :: TxIx -> TxIx
txIx (CT.TxIx Word64
i) = Word -> TxIx
TxIx (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)