-- | This module exposes the internal state in which our direct simulation is
-- run (`MockChainState`), as well as a restricted and simplified version
-- (`UtxoState`). The latter only consists of Utxos with a focus on who owns
-- those Utxos. You can see this as having some sort of an "account" view of the
-- ledger state, which typically does not exist in Cardano. This is useful for
-- two reasons:
--
-- - For printing purposes, where it is much more convient to see the available
--   assets as "who owns what" rather than as a set of mixed Utxos.
--
-- - For testings purposes, when querying the final state of a run is
--   needed. For instance, properties such as "does Alice indeed owns 3 XXX
--   tokens at the end of this run?" become much easier to express.
module Cooked.MockChain.State
  ( -- * `MockChainState` and associated optics
    MockChainState (..),
    mcstParamsL,
    mcstLedgerStateL,
    mcstOutputsL,
    mcstConstitutionL,
    mcstMOutputL,

    -- * Helpers to add or remove outputs from a `MockChainState`
    addOutput,
    removeOutput,

    -- * `UtxoState`: A simplified, address-focused view on a `MockChainState`
    UtxoPayloadDatum (..),
    utxoPayloadDatumKindAT,
    utxoPayloadDatumTypedAT,
    UtxoPayload (..),
    utxoPayloadTxOutRefL,
    utxoPayloadValueL,
    utxoPayloadDatumL,
    utxoPayloadMReferenceScriptHashL,
    utxoPayloadReferenceScriptHashAT,
    UtxoPayloadSet (..),
    utxoPayloadSetListI,
    UtxoState (..),
    availableUtxosL,
    consumedUtxosL,

    -- * Querying the assets owned by a given address
    holdsInState,

    -- * Transforming a `MockChainState` into an `UtxoState`
    mcstToUtxoState,
  )
where

import Cardano.Node.Emulator.Internal.Node qualified as Emulator
import Cooked.Skeleton
import Data.Default
import Data.Function (on)
import Data.List qualified as List
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Typeable
import Ledger.Orphans ()
import Optics.Core
import Optics.TH
import Plutus.Script.Utils.Address qualified as Script
import PlutusLedgerApi.V1.Value qualified as Api
import PlutusLedgerApi.V3 qualified as Api

-- | The state used to run the simulation in 'Cooked.MockChain.Direct'
data MockChainState where
  MockChainState ::
    { -- | The parametors of the emulated blockchain
      MockChainState -> Params
mcstParams :: Emulator.Params,
      -- | The ledger state of the emulated blockchain
      MockChainState -> EmulatedLedgerState
mcstLedgerState :: Emulator.EmulatedLedgerState,
      -- | Associates to each 'Api.TxOutRef' the 'TxSkelOut' that produced it,
      -- alongside a boolean to state whether this UTxO is still present in the
      -- index ('True') or has already been consumed ('False').
      MockChainState -> Map TxOutRef (TxSkelOut, Bool)
mcstOutputs :: Map Api.TxOutRef (TxSkelOut, Bool),
      -- | The constitution script to be used with proposals
      MockChainState -> Maybe VScript
mcstConstitution :: Maybe VScript
    } ->
    MockChainState
  deriving (Int -> MockChainState -> ShowS
[MockChainState] -> ShowS
MockChainState -> String
(Int -> MockChainState -> ShowS)
-> (MockChainState -> String)
-> ([MockChainState] -> ShowS)
-> Show MockChainState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockChainState -> ShowS
showsPrec :: Int -> MockChainState -> ShowS
$cshow :: MockChainState -> String
show :: MockChainState -> String
$cshowList :: [MockChainState] -> ShowS
showList :: [MockChainState] -> ShowS
Show)

-- | A lens to set or get the parameters of the 'MockChainState'
makeLensesFor [("mcstParams", "mcstParamsL")] ''MockChainState

-- | A lens to set or get the ledger state of the 'MockChainState'
makeLensesFor [("mcstLedgerState", "mcstLedgerStateL")] ''MockChainState

-- | A lens to set or get the outputs of the 'MockChainState'
makeLensesFor [("mcstOutputs", "mcstOutputsL")] ''MockChainState

-- | A lens to set or get the constitution script of the 'MockChainState'
makeLensesFor [("mcstConstitution", "mcstConstitutionL")] ''MockChainState

instance Default MockChainState where
  def :: MockChainState
def = Params
-> EmulatedLedgerState
-> Map TxOutRef (TxSkelOut, Bool)
-> Maybe VScript
-> MockChainState
MockChainState Params
forall a. Default a => a
def (Params -> EmulatedLedgerState
Emulator.initialState Params
forall a. Default a => a
def) Map TxOutRef (TxSkelOut, Bool)
forall k a. Map k a
Map.empty Maybe VScript
forall a. Maybe a
Nothing

-- | Accesses a given available Utxo from a `MockChainState`
mcstMOutputL :: Api.TxOutRef -> Lens' MockChainState (Maybe TxSkelOut)
mcstMOutputL :: TxOutRef -> Lens' MockChainState (Maybe TxSkelOut)
mcstMOutputL TxOutRef
oRef = Lens' MockChainState (Map TxOutRef (TxSkelOut, Bool))
mcstOutputsL Lens' MockChainState (Map TxOutRef (TxSkelOut, Bool))
-> Optic
     A_Lens
     '[]
     (Map TxOutRef (TxSkelOut, Bool))
     (Map TxOutRef (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
-> Optic
     A_Lens
     '[]
     MockChainState
     MockChainState
     (Maybe (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map TxOutRef (TxSkelOut, Bool))
-> Lens'
     (Map TxOutRef (TxSkelOut, Bool))
     (Maybe (IxValue (Map TxOutRef (TxSkelOut, Bool))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map TxOutRef (TxSkelOut, Bool))
TxOutRef
oRef Optic
  A_Lens
  '[]
  MockChainState
  MockChainState
  (Maybe (TxSkelOut, Bool))
  (Maybe (TxSkelOut, Bool))
-> Optic
     An_Iso
     '[]
     (Maybe (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
     (Maybe TxSkelOut)
     (Maybe TxSkelOut)
-> Lens' MockChainState (Maybe TxSkelOut)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Maybe (TxSkelOut, Bool) -> Maybe TxSkelOut)
-> (Maybe TxSkelOut -> Maybe (TxSkelOut, Bool))
-> Optic
     An_Iso
     '[]
     (Maybe (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
     (Maybe TxSkelOut)
     (Maybe TxSkelOut)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (((TxSkelOut, Bool) -> TxSkelOut)
-> Maybe (TxSkelOut, Bool) -> Maybe TxSkelOut
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxSkelOut, Bool) -> TxSkelOut
forall a b. (a, b) -> a
fst) ((TxSkelOut -> (TxSkelOut, Bool))
-> Maybe TxSkelOut -> Maybe (TxSkelOut, Bool)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Bool
True))

-- | Stores an output in a 'MockChainState'
addOutput :: Api.TxOutRef -> TxSkelOut -> MockChainState -> MockChainState
addOutput :: TxOutRef -> TxSkelOut -> MockChainState -> MockChainState
addOutput TxOutRef
oRef = Lens' MockChainState (Maybe TxSkelOut)
-> Maybe TxSkelOut -> MockChainState -> MockChainState
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (TxOutRef -> Lens' MockChainState (Maybe TxSkelOut)
mcstMOutputL TxOutRef
oRef) (Maybe TxSkelOut -> MockChainState -> MockChainState)
-> (TxSkelOut -> Maybe TxSkelOut)
-> TxSkelOut
-> MockChainState
-> MockChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelOut -> Maybe TxSkelOut
forall a. a -> Maybe a
Just

-- | Removes an output from the 'MockChainState'. This does not actually remove
-- it from the map, but instead marks its availability to @False@
removeOutput :: Api.TxOutRef -> MockChainState -> MockChainState
removeOutput :: TxOutRef -> MockChainState -> MockChainState
removeOutput TxOutRef
oRef = Optic
  An_AffineTraversal '[] MockChainState MockChainState Bool Bool
-> Bool -> MockChainState -> MockChainState
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Lens' MockChainState (Map TxOutRef (TxSkelOut, Bool))
mcstOutputsL Lens' MockChainState (Map TxOutRef (TxSkelOut, Bool))
-> Optic
     A_Lens
     '[]
     (Map TxOutRef (TxSkelOut, Bool))
     (Map TxOutRef (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
-> Optic
     A_Lens
     '[]
     MockChainState
     MockChainState
     (Maybe (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map TxOutRef (TxSkelOut, Bool))
-> Lens'
     (Map TxOutRef (TxSkelOut, Bool))
     (Maybe (IxValue (Map TxOutRef (TxSkelOut, Bool))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map TxOutRef (TxSkelOut, Bool))
TxOutRef
oRef Optic
  A_Lens
  '[]
  MockChainState
  MockChainState
  (Maybe (TxSkelOut, Bool))
  (Maybe (TxSkelOut, Bool))
-> Optic
     A_Prism
     '[]
     (Maybe (TxSkelOut, Bool))
     (Maybe (TxSkelOut, Bool))
     (TxSkelOut, Bool)
     (TxSkelOut, Bool)
-> Optic
     An_AffineTraversal
     '[]
     MockChainState
     MockChainState
     (TxSkelOut, Bool)
     (TxSkelOut, Bool)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Prism
  '[]
  (Maybe (TxSkelOut, Bool))
  (Maybe (TxSkelOut, Bool))
  (TxSkelOut, Bool)
  (TxSkelOut, Bool)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Optic
  An_AffineTraversal
  '[]
  MockChainState
  MockChainState
  (TxSkelOut, Bool)
  (TxSkelOut, Bool)
-> Optic A_Lens '[] (TxSkelOut, Bool) (TxSkelOut, Bool) Bool Bool
-> Optic
     An_AffineTraversal '[] MockChainState MockChainState Bool Bool
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens '[] (TxSkelOut, Bool) (TxSkelOut, Bool) Bool Bool
forall s t a b. Field2 s t a b => Lens s t a b
_2) Bool
False

-- | A simplified version of a 'Cooked.Skeleton.Datum.TxSkelOutDatum' which only
-- stores the actual datum and whether it is hashed (@True@) or inline
-- (@False@). The only difference is that whether the datum was resolved in the
-- transaction creating it on the ledger is absent, which makes sense after the
-- fact.
data UtxoPayloadDatum where
  NoUtxoPayloadDatum :: UtxoPayloadDatum
  SomeUtxoPayloadDatum :: (DatumConstrs dat) => dat -> Bool -> UtxoPayloadDatum

-- | Focuses on whether on not this `UtxoPayloadDatum` isHashed
utxoPayloadDatumKindAT :: AffineTraversal' UtxoPayloadDatum Bool
utxoPayloadDatumKindAT :: AffineTraversal' UtxoPayloadDatum Bool
utxoPayloadDatumKindAT =
  (UtxoPayloadDatum -> Either UtxoPayloadDatum Bool)
-> (UtxoPayloadDatum -> Bool -> UtxoPayloadDatum)
-> AffineTraversal' UtxoPayloadDatum Bool
forall s t a b.
(s -> Either t a) -> (s -> b -> t) -> AffineTraversal s t a b
atraversal
    ( \case
        UtxoPayloadDatum
NoUtxoPayloadDatum -> UtxoPayloadDatum -> Either UtxoPayloadDatum Bool
forall a b. a -> Either a b
Left UtxoPayloadDatum
NoUtxoPayloadDatum
        SomeUtxoPayloadDatum dat
_ Bool
b -> Bool -> Either UtxoPayloadDatum Bool
forall a b. b -> Either a b
Right Bool
b
    )
    ( (Bool -> UtxoPayloadDatum -> UtxoPayloadDatum)
-> UtxoPayloadDatum -> Bool -> UtxoPayloadDatum
forall a b c. (a -> b -> c) -> b -> a -> c
flip
        ( \Bool
kind -> \case
            UtxoPayloadDatum
NoUtxoPayloadDatum -> UtxoPayloadDatum
NoUtxoPayloadDatum
            SomeUtxoPayloadDatum dat
content Bool
_ -> dat -> Bool -> UtxoPayloadDatum
forall dat. DatumConstrs dat => dat -> Bool -> UtxoPayloadDatum
SomeUtxoPayloadDatum dat
content Bool
kind
        )
    )

-- | Extracts, or sets, the typed datum of a 'UtxoPayloadDatum' following the
-- same rules as `txSkelOutDatumTypedAT`
utxoPayloadDatumTypedAT :: (DatumConstrs a, DatumConstrs b) => AffineTraversal UtxoPayloadDatum UtxoPayloadDatum a b
utxoPayloadDatumTypedAT :: forall a b.
(DatumConstrs a, DatumConstrs b) =>
AffineTraversal UtxoPayloadDatum UtxoPayloadDatum a b
utxoPayloadDatumTypedAT =
  (UtxoPayloadDatum -> Either UtxoPayloadDatum a)
-> (UtxoPayloadDatum -> b -> UtxoPayloadDatum)
-> AffineTraversal UtxoPayloadDatum UtxoPayloadDatum a b
forall s t a b.
(s -> Either t a) -> (s -> b -> t) -> AffineTraversal s t a b
atraversal
    ( \case
        (SomeUtxoPayloadDatum dat
content Bool
_) | Just a
content' <- dat -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dat
content -> a -> Either UtxoPayloadDatum a
forall a b. b -> Either a b
Right a
content'
        (SomeUtxoPayloadDatum dat
content Bool
_) | Just a
content' <- BuiltinData -> Maybe a
forall a. FromData a => BuiltinData -> Maybe a
Api.fromBuiltinData (BuiltinData -> Maybe a) -> BuiltinData -> Maybe a
forall a b. (a -> b) -> a -> b
$ dat -> BuiltinData
forall a. ToData a => a -> BuiltinData
Api.toBuiltinData dat
content -> a -> Either UtxoPayloadDatum a
forall a b. b -> Either a b
Right a
content'
        UtxoPayloadDatum
dc -> UtxoPayloadDatum -> Either UtxoPayloadDatum a
forall a b. a -> Either a b
Left UtxoPayloadDatum
dc
    )
    ( (b -> UtxoPayloadDatum -> UtxoPayloadDatum)
-> UtxoPayloadDatum -> b -> UtxoPayloadDatum
forall a b c. (a -> b -> c) -> b -> a -> c
flip
        ( \b
content -> \case
            UtxoPayloadDatum
NoUtxoPayloadDatum -> UtxoPayloadDatum
NoUtxoPayloadDatum
            SomeUtxoPayloadDatum dat
_ Bool
kind -> b -> Bool -> UtxoPayloadDatum
forall dat. DatumConstrs dat => dat -> Bool -> UtxoPayloadDatum
SomeUtxoPayloadDatum b
content Bool
kind
        )
    )

deriving instance Show UtxoPayloadDatum

instance Ord UtxoPayloadDatum where
  compare :: UtxoPayloadDatum -> UtxoPayloadDatum -> Ordering
compare UtxoPayloadDatum
NoUtxoPayloadDatum UtxoPayloadDatum
NoUtxoPayloadDatum = Ordering
EQ
  compare UtxoPayloadDatum
NoUtxoPayloadDatum UtxoPayloadDatum
_ = Ordering
LT
  compare UtxoPayloadDatum
_ UtxoPayloadDatum
NoUtxoPayloadDatum = Ordering
GT
  compare
    (SomeUtxoPayloadDatum (dat -> BuiltinData
forall a. ToData a => a -> BuiltinData
Api.toBuiltinData -> BuiltinData
dat) Bool
b)
    (SomeUtxoPayloadDatum (dat -> BuiltinData
forall a. ToData a => a -> BuiltinData
Api.toBuiltinData -> BuiltinData
dat') Bool
b') =
      (BuiltinData, Bool) -> (BuiltinData, Bool) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BuiltinData
dat, Bool
b) (BuiltinData
dat', Bool
b')

instance Eq UtxoPayloadDatum where
  UtxoPayloadDatum
dat == :: UtxoPayloadDatum -> UtxoPayloadDatum -> Bool
== UtxoPayloadDatum
dat' = UtxoPayloadDatum -> UtxoPayloadDatum -> Ordering
forall a. Ord a => a -> a -> Ordering
compare UtxoPayloadDatum
dat UtxoPayloadDatum
dat' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- | A convenient wrapping of the interesting information of a UTxO.
data UtxoPayload where
  UtxoPayload ::
    { -- | The reference of this UTxO
      UtxoPayload -> TxOutRef
utxoPayloadTxOutRef :: Api.TxOutRef,
      -- | The value stored in this UTxO
      UtxoPayload -> Value
utxoPayloadValue :: Api.Value,
      -- | The optional datum stored in this UTxO
      UtxoPayload -> UtxoPayloadDatum
utxoPayloadDatum :: UtxoPayloadDatum,
      -- | The hash of the optional reference script stored in this UTxO
      UtxoPayload -> Maybe ScriptHash
utxoPayloadReferenceScriptHash :: Maybe Api.ScriptHash
    } ->
    UtxoPayload
  deriving (UtxoPayload -> UtxoPayload -> Bool
(UtxoPayload -> UtxoPayload -> Bool)
-> (UtxoPayload -> UtxoPayload -> Bool) -> Eq UtxoPayload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UtxoPayload -> UtxoPayload -> Bool
== :: UtxoPayload -> UtxoPayload -> Bool
$c/= :: UtxoPayload -> UtxoPayload -> Bool
/= :: UtxoPayload -> UtxoPayload -> Bool
Eq, Int -> UtxoPayload -> ShowS
[UtxoPayload] -> ShowS
UtxoPayload -> String
(Int -> UtxoPayload -> ShowS)
-> (UtxoPayload -> String)
-> ([UtxoPayload] -> ShowS)
-> Show UtxoPayload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UtxoPayload -> ShowS
showsPrec :: Int -> UtxoPayload -> ShowS
$cshow :: UtxoPayload -> String
show :: UtxoPayload -> String
$cshowList :: [UtxoPayload] -> ShowS
showList :: [UtxoPayload] -> ShowS
Show)

-- | A lens to set or get the UTxO reference from this `UtxoPayload`
makeLensesFor [("utxoPayloadTxOutRef", "utxoPayloadTxOutRefL")] ''UtxoPayload

-- | A lens to set or get the value from this `UtxoPayload`
makeLensesFor [("utxoPayloadValue", "utxoPayloadValueL")] ''UtxoPayload

-- | A lens to set or get the datum from this `UtxoPayload`
makeLensesFor [("utxoPayloadDatum", "utxoPayloadDatumL")] ''UtxoPayload

-- | A lens to set or get the optional reference script hash from this
-- `UtxoPayload`
makeLensesFor [("utxoPayloadReferenceScriptHash", "utxoPayloadMReferenceScriptHashL")] ''UtxoPayload

-- | Focusing on the optional reference script hash of a `UtxoPayload`
utxoPayloadReferenceScriptHashAT :: AffineTraversal' UtxoPayload Api.ScriptHash
utxoPayloadReferenceScriptHashAT :: AffineTraversal' UtxoPayload ScriptHash
utxoPayloadReferenceScriptHashAT = Lens' UtxoPayload (Maybe ScriptHash)
utxoPayloadMReferenceScriptHashL Lens' UtxoPayload (Maybe ScriptHash)
-> Optic
     A_Prism
     '[]
     (Maybe ScriptHash)
     (Maybe ScriptHash)
     ScriptHash
     ScriptHash
-> AffineTraversal' UtxoPayload ScriptHash
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Prism
  '[]
  (Maybe ScriptHash)
  (Maybe ScriptHash)
  ScriptHash
  ScriptHash
forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Represents a /set/ of payloads.
newtype UtxoPayloadSet = UtxoPayloadSet
  { -- | List of UTxOs contained in this 'UtxoPayloadSet'
    UtxoPayloadSet -> [UtxoPayload]
utxoPayloadSet :: [UtxoPayload]
    -- We use a list instead of a set because 'Api.Value' doesn't implement 'Ord'
    -- and because it is possible that we want to distinguish between utxo states
    -- that have additional utxos, even if these could have been merged together.
  }
  deriving (Int -> UtxoPayloadSet -> ShowS
[UtxoPayloadSet] -> ShowS
UtxoPayloadSet -> String
(Int -> UtxoPayloadSet -> ShowS)
-> (UtxoPayloadSet -> String)
-> ([UtxoPayloadSet] -> ShowS)
-> Show UtxoPayloadSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UtxoPayloadSet -> ShowS
showsPrec :: Int -> UtxoPayloadSet -> ShowS
$cshow :: UtxoPayloadSet -> String
show :: UtxoPayloadSet -> String
$cshowList :: [UtxoPayloadSet] -> ShowS
showList :: [UtxoPayloadSet] -> ShowS
Show)

-- | Going back and forth between a list of `UtxoPayload` and a `UtxoPayloadSet`
utxoPayloadSetListI :: Iso' UtxoPayloadSet [UtxoPayload]
utxoPayloadSetListI :: Iso' UtxoPayloadSet [UtxoPayload]
utxoPayloadSetListI = (UtxoPayloadSet -> [UtxoPayload])
-> ([UtxoPayload] -> UtxoPayloadSet)
-> Iso' UtxoPayloadSet [UtxoPayload]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso UtxoPayloadSet -> [UtxoPayload]
utxoPayloadSet [UtxoPayload] -> UtxoPayloadSet
UtxoPayloadSet

instance Eq UtxoPayloadSet where
  (UtxoPayloadSet [UtxoPayload]
xs) == :: UtxoPayloadSet -> UtxoPayloadSet -> Bool
== (UtxoPayloadSet [UtxoPayload]
ys) = [UtxoPayload]
xs' [UtxoPayload] -> [UtxoPayload] -> Bool
forall a. Eq a => a -> a -> Bool
== [UtxoPayload]
ys'
    where
      k :: UtxoPayload
-> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
    UtxoPayloadDatum, Maybe ScriptHash)
k (UtxoPayload TxOutRef
ref Value
val UtxoPayloadDatum
dat Maybe ScriptHash
rs) = (TxOutRef
ref, Value -> [(CurrencySymbol, TokenName, Integer)]
Api.flattenValue Value
val, UtxoPayloadDatum
dat, Maybe ScriptHash
rs)
      xs' :: [UtxoPayload]
xs' = (UtxoPayload -> UtxoPayload -> Ordering)
-> [UtxoPayload] -> [UtxoPayload]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy ((TxOutRef, [(CurrencySymbol, TokenName, Integer)],
 UtxoPayloadDatum, Maybe ScriptHash)
-> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
    UtxoPayloadDatum, Maybe ScriptHash)
-> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((TxOutRef, [(CurrencySymbol, TokenName, Integer)],
  UtxoPayloadDatum, Maybe ScriptHash)
 -> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
     UtxoPayloadDatum, Maybe ScriptHash)
 -> Ordering)
-> (UtxoPayload
    -> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
        UtxoPayloadDatum, Maybe ScriptHash))
-> UtxoPayload
-> UtxoPayload
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` UtxoPayload
-> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
    UtxoPayloadDatum, Maybe ScriptHash)
k) [UtxoPayload]
xs
      ys' :: [UtxoPayload]
ys' = (UtxoPayload -> UtxoPayload -> Ordering)
-> [UtxoPayload] -> [UtxoPayload]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy ((TxOutRef, [(CurrencySymbol, TokenName, Integer)],
 UtxoPayloadDatum, Maybe ScriptHash)
-> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
    UtxoPayloadDatum, Maybe ScriptHash)
-> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((TxOutRef, [(CurrencySymbol, TokenName, Integer)],
  UtxoPayloadDatum, Maybe ScriptHash)
 -> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
     UtxoPayloadDatum, Maybe ScriptHash)
 -> Ordering)
-> (UtxoPayload
    -> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
        UtxoPayloadDatum, Maybe ScriptHash))
-> UtxoPayload
-> UtxoPayload
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` UtxoPayload
-> (TxOutRef, [(CurrencySymbol, TokenName, Integer)],
    UtxoPayloadDatum, Maybe ScriptHash)
k) [UtxoPayload]
ys

instance Semigroup UtxoPayloadSet where
  UtxoPayloadSet [UtxoPayload]
a <> :: UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet
<> UtxoPayloadSet [UtxoPayload]
b = [UtxoPayload] -> UtxoPayloadSet
UtxoPayloadSet ([UtxoPayload] -> UtxoPayloadSet)
-> [UtxoPayload] -> UtxoPayloadSet
forall a b. (a -> b) -> a -> b
$ [UtxoPayload]
a [UtxoPayload] -> [UtxoPayload] -> [UtxoPayload]
forall a. [a] -> [a] -> [a]
++ [UtxoPayload]
b

instance Monoid UtxoPayloadSet where
  mempty :: UtxoPayloadSet
mempty = [UtxoPayload] -> UtxoPayloadSet
UtxoPayloadSet []

-- | A description of who owns what in a blockchain. Owners are addresses and
-- they each own a 'UtxoPayloadSet'.
data UtxoState where
  UtxoState ::
    { -- | Utxos available to be consumed
      UtxoState -> Map Address UtxoPayloadSet
availableUtxos :: Map Api.Address UtxoPayloadSet,
      -- | Utxos already consumed
      UtxoState -> Map Address UtxoPayloadSet
consumedUtxos :: Map Api.Address UtxoPayloadSet
    } ->
    UtxoState
  deriving (UtxoState -> UtxoState -> Bool
(UtxoState -> UtxoState -> Bool)
-> (UtxoState -> UtxoState -> Bool) -> Eq UtxoState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UtxoState -> UtxoState -> Bool
== :: UtxoState -> UtxoState -> Bool
$c/= :: UtxoState -> UtxoState -> Bool
/= :: UtxoState -> UtxoState -> Bool
Eq)

-- | A lens to set or get the available UTxOs from a `UtxoState`
makeLensesFor [("availableUtxos", "availableUtxosL")] ''UtxoState

-- | A lens to set or get the consumed UTxOs from a `UtxoState`
makeLensesFor [("consumedUtxos", "consumedUtxosL")] ''UtxoState

instance Semigroup UtxoState where
  (UtxoState Map Address UtxoPayloadSet
a Map Address UtxoPayloadSet
c) <> :: UtxoState -> UtxoState -> UtxoState
<> (UtxoState Map Address UtxoPayloadSet
a' Map Address UtxoPayloadSet
c') = Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet -> UtxoState
UtxoState ((UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet)
-> Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet
forall a. Semigroup a => a -> a -> a
(<>) Map Address UtxoPayloadSet
a Map Address UtxoPayloadSet
a') ((UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet)
-> Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet
forall a. Semigroup a => a -> a -> a
(<>) Map Address UtxoPayloadSet
c Map Address UtxoPayloadSet
c')

instance Monoid UtxoState where
  mempty :: UtxoState
mempty = Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet -> UtxoState
UtxoState Map Address UtxoPayloadSet
forall k a. Map k a
Map.empty Map Address UtxoPayloadSet
forall k a. Map k a
Map.empty

-- | Total value accessible to what's pointed by the address.
holdsInState :: (Script.ToAddress a) => a -> UtxoState -> Api.Value
holdsInState :: forall a. ToAddress a => a -> UtxoState -> Value
holdsInState (a -> Address
forall a. ToAddress a => a -> Address
Script.toAddress -> Address
address) = Value -> (UtxoPayloadSet -> Value) -> Maybe UtxoPayloadSet -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
forall a. Monoid a => a
mempty UtxoPayloadSet -> Value
utxoPayloadSetTotal (Maybe UtxoPayloadSet -> Value)
-> (UtxoState -> Maybe UtxoPayloadSet) -> UtxoState -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Lens '[] UtxoState (Maybe UtxoPayloadSet)
-> UtxoState -> Maybe UtxoPayloadSet
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' UtxoState (Map Address UtxoPayloadSet)
availableUtxosL Lens' UtxoState (Map Address UtxoPayloadSet)
-> Optic
     A_Lens
     '[]
     (Map Address UtxoPayloadSet)
     (Map Address UtxoPayloadSet)
     (Maybe UtxoPayloadSet)
     (Maybe UtxoPayloadSet)
-> Optic' A_Lens '[] UtxoState (Maybe UtxoPayloadSet)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map Address UtxoPayloadSet)
-> Lens'
     (Map Address UtxoPayloadSet)
     (Maybe (IxValue (Map Address UtxoPayloadSet)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Address UtxoPayloadSet)
Address
address)

-- | Computes the total value in a set
utxoPayloadSetTotal :: UtxoPayloadSet -> Api.Value
utxoPayloadSetTotal :: UtxoPayloadSet -> Value
utxoPayloadSetTotal = Optic' A_Fold '[] UtxoPayloadSet Value -> UtxoPayloadSet -> Value
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf (Iso' UtxoPayloadSet [UtxoPayload]
utxoPayloadSetListI Iso' UtxoPayloadSet [UtxoPayload]
-> Optic
     A_Fold '[] [UtxoPayload] [UtxoPayload] UtxoPayload UtxoPayload
-> Optic
     A_Fold '[] UtxoPayloadSet UtxoPayloadSet UtxoPayload UtxoPayload
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Fold '[] [UtxoPayload] [UtxoPayload] UtxoPayload UtxoPayload
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Optic
  A_Fold '[] UtxoPayloadSet UtxoPayloadSet UtxoPayload UtxoPayload
-> Lens' UtxoPayload Value
-> Optic' A_Fold '[] UtxoPayloadSet Value
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' UtxoPayload Value
utxoPayloadValueL)

-- | Builds a 'UtxoState' from a 'MockChainState'
mcstToUtxoState :: MockChainState -> UtxoState
mcstToUtxoState :: MockChainState -> UtxoState
mcstToUtxoState =
  (UtxoState -> (TxOutRef, (TxSkelOut, Bool)) -> UtxoState)
-> UtxoState -> [(TxOutRef, (TxSkelOut, Bool))] -> UtxoState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl UtxoState -> (TxOutRef, (TxSkelOut, Bool)) -> UtxoState
extractPayload UtxoState
forall a. Monoid a => a
mempty ([(TxOutRef, (TxSkelOut, Bool))] -> UtxoState)
-> (MockChainState -> [(TxOutRef, (TxSkelOut, Bool))])
-> MockChainState
-> UtxoState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxOutRef (TxSkelOut, Bool) -> [(TxOutRef, (TxSkelOut, Bool))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxOutRef (TxSkelOut, Bool) -> [(TxOutRef, (TxSkelOut, Bool))])
-> (MockChainState -> Map TxOutRef (TxSkelOut, Bool))
-> MockChainState
-> [(TxOutRef, (TxSkelOut, Bool))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainState -> Map TxOutRef (TxSkelOut, Bool)
mcstOutputs
  where
    extractPayload :: UtxoState -> (Api.TxOutRef, (TxSkelOut, Bool)) -> UtxoState
    extractPayload :: UtxoState -> (TxOutRef, (TxSkelOut, Bool)) -> UtxoState
extractPayload UtxoState
utxoState (TxOutRef
txOutRef, (TxSkelOut
txSkelOut, Bool
bool)) =
      let newAddress :: Address
newAddress = Optic' A_Getter '[] TxSkelOut Address -> TxSkelOut -> Address
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Getter '[] TxSkelOut Address
txSkelOutAddressG TxSkelOut
txSkelOut
          newPayloadSet :: UtxoPayloadSet
newPayloadSet =
            [UtxoPayload] -> UtxoPayloadSet
UtxoPayloadSet
              [ TxOutRef
-> Value -> UtxoPayloadDatum -> Maybe ScriptHash -> UtxoPayload
UtxoPayload
                  TxOutRef
txOutRef
                  (Optic' A_Lens '[] TxSkelOut Value -> TxSkelOut -> Value
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] TxSkelOut Value
txSkelOutValueL TxSkelOut
txSkelOut)
                  ( case TxSkelOut
txSkelOut TxSkelOut
-> Optic' A_Lens '[] TxSkelOut TxSkelOutDatum -> TxSkelOutDatum
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens '[] TxSkelOut TxSkelOutDatum
txSkelOutDatumL of
                      TxSkelOutDatum
NoTxSkelOutDatum -> UtxoPayloadDatum
NoUtxoPayloadDatum
                      SomeTxSkelOutDatum dat
content DatumKind
kind -> dat -> Bool -> UtxoPayloadDatum
forall dat. DatumConstrs dat => dat -> Bool -> UtxoPayloadDatum
SomeUtxoPayloadDatum dat
content (DatumKind
kind DatumKind -> DatumKind -> Bool
forall a. Eq a => a -> a -> Bool
/= DatumKind
Inline)
                  )
                  (Optic' An_AffineFold '[] TxSkelOut ScriptHash
-> TxSkelOut -> Maybe ScriptHash
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' An_AffineFold '[] TxSkelOut ScriptHash
txSkelOutReferenceScriptHashAF TxSkelOut
txSkelOut)
              ]
       in if Bool
bool
            then UtxoState
utxoState {availableUtxos = Map.insertWith (<>) newAddress newPayloadSet (availableUtxos utxoState)}
            else UtxoState
utxoState {consumedUtxos = Map.insertWith (<>) newAddress newPayloadSet (consumedUtxos utxoState)}