-- | This module exposes the internal state in which our direct simulation is
-- run, and functions to update and querry it.
module Cooked.MockChain.MockChainSt where

import Cardano.Api qualified as Cardano
import Cardano.Api.Shelley qualified as Cardano
import Cardano.Ledger.Shelley.API qualified as Shelley
import Cardano.Ledger.Shelley.LedgerState qualified as Shelley
import Cardano.Node.Emulator.Internal.Node qualified as Emulator
import Control.Monad
import Control.Monad.Except
import Cooked.InitialDistribution
import Cooked.MockChain.BlockChain
import Cooked.MockChain.GenerateTx
import Cooked.MockChain.GenerateTx.Output
import Cooked.MockChain.MinAda
import Cooked.MockChain.UtxoState
import Cooked.Output
import Cooked.Skeleton
import Data.Bifunctor (bimap)
import Data.Default
import Data.List (foldl')
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe)
import Ledger.Index qualified as Ledger
import Ledger.Orphans ()
import Ledger.Slot qualified as Ledger
import Ledger.Tx qualified as Ledger
import Ledger.Tx.CardanoAPI qualified as Ledger
import Optics.Core (view)
import Plutus.Script.Utils.Data qualified as Script
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- | The state used to run the simulation in 'Cooked.MockChain.Direct'
data MockChainSt = MockChainSt
  { MockChainSt -> Params
mcstParams :: Emulator.Params,
    MockChainSt -> UtxoIndex
mcstIndex :: Ledger.UtxoIndex,
    -- map from datum hash to (datum, count), where count is the number of UTxOs
    -- that currently have the datum. This map is used to display the contents
    -- of the state to the user, and to recover datums for transaction
    -- generation.
    MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map Api.DatumHash (TxSkelOutDatum, Integer),
    MockChainSt -> Map ScriptHash (Versioned Script)
mcstScripts :: Map Script.ScriptHash (Script.Versioned Script.Script),
    MockChainSt -> Slot
mcstCurrentSlot :: Ledger.Slot
  }
  deriving (Int -> MockChainSt -> ShowS
[MockChainSt] -> ShowS
MockChainSt -> String
(Int -> MockChainSt -> ShowS)
-> (MockChainSt -> String)
-> ([MockChainSt] -> ShowS)
-> Show MockChainSt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockChainSt -> ShowS
showsPrec :: Int -> MockChainSt -> ShowS
$cshow :: MockChainSt -> String
show :: MockChainSt -> String
$cshowList :: [MockChainSt] -> ShowS
showList :: [MockChainSt] -> ShowS
Show, MockChainSt -> MockChainSt -> Bool
(MockChainSt -> MockChainSt -> Bool)
-> (MockChainSt -> MockChainSt -> Bool) -> Eq MockChainSt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MockChainSt -> MockChainSt -> Bool
== :: MockChainSt -> MockChainSt -> Bool
$c/= :: MockChainSt -> MockChainSt -> Bool
/= :: MockChainSt -> MockChainSt -> Bool
Eq)

instance Default MockChainSt where
  def :: MockChainSt
def = Params
-> UtxoIndex
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map ScriptHash (Versioned Script)
-> Slot
-> MockChainSt
MockChainSt Params
forall a. Default a => a
def (Blockchain -> UtxoIndex
Ledger.initialise [[]]) Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Map k a
Map.empty Map ScriptHash (Versioned Script)
forall k a. Map k a
Map.empty Slot
0

-- | Converts a builtin UtxoIndex into our own usable map between utxos and
-- associated outputs.
getIndex :: Ledger.UtxoIndex -> Map Api.TxOutRef Api.TxOut
getIndex :: UtxoIndex -> Map TxOutRef TxOut
getIndex =
  [(TxOutRef, TxOut)] -> Map TxOutRef TxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(TxOutRef, TxOut)] -> Map TxOutRef TxOut)
-> (UtxoIndex -> [(TxOutRef, TxOut)])
-> UtxoIndex
-> Map TxOutRef TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO ConwayEra) -> (TxOutRef, TxOut))
-> [(TxIn, TxOut CtxUTxO ConwayEra)] -> [(TxOutRef, TxOut)]
forall a b. (a -> b) -> [a] -> [b]
map ((TxIn -> TxOutRef)
-> (TxOut CtxUTxO ConwayEra -> TxOut)
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> (TxOutRef, TxOut)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxIn -> TxOutRef
Ledger.fromCardanoTxIn (TxOut CtxTx ConwayEra -> TxOut
forall era. TxOut CtxTx era -> TxOut
Ledger.fromCardanoTxOutToPV2TxInfoTxOut (TxOut CtxTx ConwayEra -> TxOut)
-> (TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra)
-> TxOut CtxUTxO ConwayEra
-> TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
toCtxTxTxOut))
    ([(TxIn, TxOut CtxUTxO ConwayEra)] -> [(TxOutRef, TxOut)])
-> (UtxoIndex -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> UtxoIndex
-> [(TxOutRef, TxOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut CtxUTxO ConwayEra)
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall k a. Map k a -> [(k, a)]
Map.toList
    (Map TxIn (TxOut CtxUTxO ConwayEra)
 -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> (UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra))
-> UtxoIndex
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut CtxUTxO era)
Cardano.unUTxO
  where
    -- We need to convert a UTxO context TxOut to a Transaction context Tx out.
    -- It's complicated because the datum type is indexed by the context.
    toCtxTxTxOut :: Cardano.TxOut Cardano.CtxUTxO era -> Cardano.TxOut Cardano.CtxTx era
    toCtxTxTxOut :: forall era. TxOut CtxUTxO era -> TxOut CtxTx era
toCtxTxTxOut (Cardano.TxOut AddressInEra era
addr TxOutValue era
val TxOutDatum CtxUTxO era
d ReferenceScript era
refS) =
      let dat :: TxOutDatum CtxTx era
dat = case TxOutDatum CtxUTxO era
d of
            TxOutDatum CtxUTxO era
Cardano.TxOutDatumNone -> TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
Cardano.TxOutDatumNone
            Cardano.TxOutDatumHash AlonzoEraOnwards era
s Hash ScriptData
h -> AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum CtxTx era
forall era ctx.
AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum ctx era
Cardano.TxOutDatumHash AlonzoEraOnwards era
s Hash ScriptData
h
            Cardano.TxOutDatumInline BabbageEraOnwards era
s HashableScriptData
sd -> BabbageEraOnwards era -> HashableScriptData -> TxOutDatum CtxTx era
forall era ctx.
BabbageEraOnwards era -> HashableScriptData -> TxOutDatum ctx era
Cardano.TxOutDatumInline BabbageEraOnwards era
s HashableScriptData
sd
       in AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
Cardano.TxOut AddressInEra era
addr TxOutValue era
val TxOutDatum CtxTx era
dat ReferenceScript era
refS

-- | Builds a 'UtxoState' from a 'MockChainSt'
mcstToUtxoState :: MockChainSt -> UtxoState
mcstToUtxoState :: MockChainSt -> UtxoState
mcstToUtxoState MockChainSt {UtxoIndex
mcstIndex :: MockChainSt -> UtxoIndex
mcstIndex :: UtxoIndex
mcstIndex, Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums} =
  Map Address UtxoPayloadSet -> UtxoState
UtxoState
    (Map Address UtxoPayloadSet -> UtxoState)
-> (UtxoIndex -> Map Address UtxoPayloadSet)
-> UtxoIndex
-> UtxoState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Address, UtxoPayloadSet)
 -> Map Address UtxoPayloadSet -> Map Address UtxoPayloadSet)
-> Map Address UtxoPayloadSet
-> [(Address, UtxoPayloadSet)]
-> Map Address UtxoPayloadSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Address
address, UtxoPayloadSet
utxoValueSet) Map Address UtxoPayloadSet
acc -> (UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet)
-> Address
-> UtxoPayloadSet
-> Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet
forall a. Semigroup a => a -> a -> a
(<>) Address
address UtxoPayloadSet
utxoValueSet Map Address UtxoPayloadSet
acc) Map Address UtxoPayloadSet
forall k a. Map k a
Map.empty
    ([(Address, UtxoPayloadSet)] -> Map Address UtxoPayloadSet)
-> (UtxoIndex -> [(Address, UtxoPayloadSet)])
-> UtxoIndex
-> Map Address UtxoPayloadSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO ConwayEra)
 -> Maybe (Address, UtxoPayloadSet))
-> [(TxIn, TxOut CtxUTxO ConwayEra)] -> [(Address, UtxoPayloadSet)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      ( (TxOutRef, TxOut) -> Maybe (Address, UtxoPayloadSet)
extractPayload
          ((TxOutRef, TxOut) -> Maybe (Address, UtxoPayloadSet))
-> ((TxIn, TxOut CtxUTxO ConwayEra) -> (TxOutRef, TxOut))
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> Maybe (Address, UtxoPayloadSet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn -> TxOutRef)
-> (TxOut CtxUTxO ConwayEra -> TxOut)
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> (TxOutRef, TxOut)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
            TxIn -> TxOutRef
Ledger.fromCardanoTxIn
            TxOut CtxUTxO ConwayEra -> TxOut
forall era. TxOut CtxUTxO era -> TxOut
Ledger.fromCardanoTxOutToPV2TxInfoTxOut'
      )
    ([(TxIn, TxOut CtxUTxO ConwayEra)] -> [(Address, UtxoPayloadSet)])
-> (UtxoIndex -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> UtxoIndex
-> [(Address, UtxoPayloadSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut CtxUTxO ConwayEra)
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall k a. Map k a -> [(k, a)]
Map.toList
    (Map TxIn (TxOut CtxUTxO ConwayEra)
 -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> (UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra))
-> UtxoIndex
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut CtxUTxO era)
Cardano.unUTxO
    (UtxoIndex -> UtxoState) -> UtxoIndex -> UtxoState
forall a b. (a -> b) -> a -> b
$ UtxoIndex
mcstIndex
  where
    extractPayload :: (Api.TxOutRef, Api.TxOut) -> Maybe (Api.Address, UtxoPayloadSet)
    extractPayload :: (TxOutRef, TxOut) -> Maybe (Address, UtxoPayloadSet)
extractPayload (TxOutRef
txOutRef, out :: TxOut
out@Api.TxOut {Address
txOutAddress :: Address
txOutAddress :: TxOut -> Address
Api.txOutAddress, Value
txOutValue :: Value
txOutValue :: TxOut -> Value
Api.txOutValue, OutputDatum
txOutDatum :: OutputDatum
txOutDatum :: TxOut -> OutputDatum
Api.txOutDatum}) =
      do
        let mRefScript :: Maybe ScriptHash
mRefScript = TxOut -> Maybe ScriptHash
forall o.
(IsAbstractOutput o, ToScriptHash (ReferenceScriptType o)) =>
o -> Maybe ScriptHash
outputReferenceScriptHash TxOut
out
        TxSkelOutDatum
txSkelOutDatum <-
          case OutputDatum
txOutDatum of
            OutputDatum
Api.NoOutputDatum -> TxSkelOutDatum -> Maybe TxSkelOutDatum
forall a. a -> Maybe a
Just TxSkelOutDatum
TxSkelOutNoDatum
            Api.OutputDatum Datum
datum -> (TxSkelOutDatum, Integer) -> TxSkelOutDatum
forall a b. (a, b) -> a
fst ((TxSkelOutDatum, Integer) -> TxSkelOutDatum)
-> Maybe (TxSkelOutDatum, Integer) -> Maybe TxSkelOutDatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatumHash
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Maybe (TxSkelOutDatum, Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Datum -> DatumHash
Script.datumHash Datum
datum) Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums
            Api.OutputDatumHash DatumHash
hash -> (TxSkelOutDatum, Integer) -> TxSkelOutDatum
forall a b. (a, b) -> a
fst ((TxSkelOutDatum, Integer) -> TxSkelOutDatum)
-> Maybe (TxSkelOutDatum, Integer) -> Maybe TxSkelOutDatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatumHash
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Maybe (TxSkelOutDatum, Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DatumHash
hash Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums
        (Address, UtxoPayloadSet) -> Maybe (Address, UtxoPayloadSet)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
          ( Address
txOutAddress,
            [UtxoPayload] -> UtxoPayloadSet
UtxoPayloadSet [TxOutRef
-> Value -> TxSkelOutDatum -> Maybe ScriptHash -> UtxoPayload
UtxoPayload TxOutRef
txOutRef Value
txOutValue TxSkelOutDatum
txSkelOutDatum Maybe ScriptHash
mRefScript]
          )

-- | Generating an emulated state for the emulator from a mockchain state and
-- some parameters, based on a standard initial state
mcstToEmulatedLedgerState :: MockChainSt -> Emulator.EmulatedLedgerState
mcstToEmulatedLedgerState :: MockChainSt -> EmulatedLedgerState
mcstToEmulatedLedgerState MockChainSt {Map DatumHash (TxSkelOutDatum, Integer)
Map ScriptHash (Versioned Script)
UtxoIndex
Params
Slot
mcstParams :: MockChainSt -> Params
mcstIndex :: MockChainSt -> UtxoIndex
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstScripts :: MockChainSt -> Map ScriptHash (Versioned Script)
mcstCurrentSlot :: MockChainSt -> Slot
mcstParams :: Params
mcstIndex :: UtxoIndex
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstScripts :: Map ScriptHash (Versioned Script)
mcstCurrentSlot :: Slot
..} =
  let els :: EmulatedLedgerState
els@(Emulator.EmulatedLedgerState MempoolEnv EmulatorEra
le LedgerState EmulatorEra
mps) = Params -> EmulatedLedgerState
Emulator.initialState Params
mcstParams
   in EmulatedLedgerState
els
        { Emulator._ledgerEnv = le {Shelley.ledgerSlotNo = fromIntegral mcstCurrentSlot},
          Emulator._memPoolState =
            mps
              { Shelley.lsUTxOState =
                  Shelley.smartUTxOState
                    (Emulator.emulatorPParams mcstParams)
                    (Ledger.fromPlutusIndex mcstIndex)
                    (Emulator.Coin 0)
                    (Emulator.Coin 0)
                    def
                    (Emulator.Coin 0)
              }
        }

-- | Adds a list of pairs @(datumHash, datum)@ into a 'MockChainSt'
addDatums :: [(Api.DatumHash, TxSkelOutDatum)] -> MockChainSt -> MockChainSt
addDatums :: [(DatumHash, TxSkelOutDatum)] -> MockChainSt -> MockChainSt
addDatums [(DatumHash, TxSkelOutDatum)]
toAdd st :: MockChainSt
st@(MockChainSt {Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums}) =
  MockChainSt
st
    { mcstDatums =
        foldl
          ( \Map DatumHash (TxSkelOutDatum, Integer)
datumMap (DatumHash
dHash, TxSkelOutDatum
dat) ->
              ((TxSkelOutDatum, Integer)
 -> (TxSkelOutDatum, Integer) -> (TxSkelOutDatum, Integer))
-> DatumHash
-> (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\(TxSkelOutDatum
d, Integer
n) (TxSkelOutDatum
_, Integer
n') -> (TxSkelOutDatum
d, Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n')) DatumHash
dHash (TxSkelOutDatum
dat, Integer
1) Map DatumHash (TxSkelOutDatum, Integer)
datumMap
          )
          mcstDatums
          toAdd
    }

-- | Removes a certain amound of datum hashes from a 'MockChainSt'
removeDatums :: [Api.DatumHash] -> MockChainSt -> MockChainSt
removeDatums :: [DatumHash] -> MockChainSt -> MockChainSt
removeDatums [DatumHash]
toRemove st :: MockChainSt
st@(MockChainSt {Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums}) =
  MockChainSt
st
    { mcstDatums =
        foldl
          (flip (Map.update (\(TxSkelOutDatum
dat, Integer
n) -> (TxSkelOutDatum
dat,) (Integer -> (TxSkelOutDatum, Integer))
-> Maybe Integer -> Maybe (TxSkelOutDatum, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Maybe Integer
minusMaybe Integer
n)))
          mcstDatums
          toRemove
    }
  where
    -- This is unsafe as this assumes n >= 1
    minusMaybe :: Integer -> Maybe Integer
    minusMaybe :: Integer -> Maybe Integer
minusMaybe Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = Maybe Integer
forall a. Maybe a
Nothing
    minusMaybe Integer
n = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

-- | Stores a script in a 'MockChainSt'
addScript :: (Script.ToScriptHash s, Script.ToVersioned Script.Script s) => s -> MockChainSt -> MockChainSt
addScript :: forall s.
(ToScriptHash s, ToVersioned Script s) =>
s -> MockChainSt -> MockChainSt
addScript s
script MockChainSt
st = MockChainSt
st {mcstScripts = Map.insert (Script.toScriptHash script) (Script.toVersioned script) (mcstScripts st)}

-- * Initial `MockChainSt` from an 'InitialDistribution'

-- | Builds a 'MockChainSt' from an 'InitialDistribution'. This lives in
-- 'MonadBlockChainBalancing' because the creation of 'mcstIndex' is impure
mockChainSt0From :: (MonadBlockChainBalancing m) => InitialDistribution -> m MockChainSt
mockChainSt0From :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m MockChainSt
mockChainSt0From InitialDistribution
i0 = (\UtxoIndex
x -> Params
-> UtxoIndex
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map ScriptHash (Versioned Script)
-> Slot
-> MockChainSt
MockChainSt Params
forall a. Default a => a
def UtxoIndex
x (InitialDistribution -> Map DatumHash (TxSkelOutDatum, Integer)
datumMap0From InitialDistribution
i0) (InitialDistribution -> Map ScriptHash (Versioned Script)
referenceScriptMap0From InitialDistribution
i0 Map ScriptHash (Versioned Script)
-> Map ScriptHash (Versioned Script)
-> Map ScriptHash (Versioned Script)
forall a. Semigroup a => a -> a -> a
<> InitialDistribution -> Map ScriptHash (Versioned Script)
scriptMap0From InitialDistribution
i0) Slot
0) (UtxoIndex -> MockChainSt) -> m UtxoIndex -> m MockChainSt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitialDistribution -> m UtxoIndex
forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m UtxoIndex
utxoIndex0From InitialDistribution
i0

-- | Collects the reference scripts present in an 'InitialDistribution'
referenceScriptMap0From :: InitialDistribution -> Map Script.ScriptHash (Script.Versioned Script.Script)
referenceScriptMap0From :: InitialDistribution -> Map ScriptHash (Versioned Script)
referenceScriptMap0From =
  -- This builds a map of entries from the reference scripts contained in the
  -- initial distribution
  [(ScriptHash, Versioned Script)]
-> Map ScriptHash (Versioned Script)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, Versioned Script)]
 -> Map ScriptHash (Versioned Script))
-> (InitialDistribution -> [(ScriptHash, Versioned Script)])
-> InitialDistribution
-> Map ScriptHash (Versioned Script)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut -> Maybe (ScriptHash, Versioned Script))
-> [TxSkelOut] -> [(ScriptHash, Versioned Script)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxSkelOut -> Maybe (ScriptHash, Versioned Script)
unitMaybeFrom ([TxSkelOut] -> [(ScriptHash, Versioned Script)])
-> (InitialDistribution -> [TxSkelOut])
-> InitialDistribution
-> [(ScriptHash, Versioned Script)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialDistribution -> [TxSkelOut]
unInitialDistribution
  where
    -- This takes a single output and returns a possible map entry when it
    -- contains a reference script
    unitMaybeFrom :: TxSkelOut -> Maybe (Script.ScriptHash, Script.Versioned Script.Script)
    unitMaybeFrom :: TxSkelOut -> Maybe (ScriptHash, Versioned Script)
unitMaybeFrom (Pays o
output) = do
      Versioned Script
vScript <- forall s a. ToVersioned s a => a -> Versioned s
Script.toVersioned @Script.Script (ReferenceScriptType o -> Versioned Script)
-> Maybe (ReferenceScriptType o) -> Maybe (Versioned Script)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic' A_Lens NoIx o (Maybe (ReferenceScriptType o))
-> o -> Maybe (ReferenceScriptType o)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx o (Maybe (ReferenceScriptType o))
forall o.
IsAbstractOutput o =>
Lens' o (Maybe (ReferenceScriptType o))
outputReferenceScriptL o
output
      (ScriptHash, Versioned Script)
-> Maybe (ScriptHash, Versioned Script)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Versioned Script -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
Script.toScriptHash Versioned Script
vScript, Versioned Script
vScript)

-- | Collects the scripts paid to in an 'InitialDistribution'
scriptMap0From :: InitialDistribution -> Map Script.ScriptHash (Script.Versioned Script.Script)
scriptMap0From :: InitialDistribution -> Map ScriptHash (Versioned Script)
scriptMap0From =
  -- This builds a map of entries from the scripts contained in the initial
  -- distribution
  [(ScriptHash, Versioned Script)]
-> Map ScriptHash (Versioned Script)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, Versioned Script)]
 -> Map ScriptHash (Versioned Script))
-> (InitialDistribution -> [(ScriptHash, Versioned Script)])
-> InitialDistribution
-> Map ScriptHash (Versioned Script)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut -> Maybe (ScriptHash, Versioned Script))
-> [TxSkelOut] -> [(ScriptHash, Versioned Script)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxSkelOut -> Maybe (ScriptHash, Versioned Script)
unitMaybeFrom ([TxSkelOut] -> [(ScriptHash, Versioned Script)])
-> (InitialDistribution -> [TxSkelOut])
-> InitialDistribution
-> [(ScriptHash, Versioned Script)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialDistribution -> [TxSkelOut]
unInitialDistribution
  where
    -- This takes a single output and returns a possible map entry when it
    -- contains a script
    unitMaybeFrom :: TxSkelOut -> Maybe (Script.ScriptHash, Script.Versioned Script.Script)
    unitMaybeFrom :: TxSkelOut -> Maybe (ScriptHash, Versioned Script)
unitMaybeFrom TxSkelOut
txSkelOut = do
      Versioned Validator
val <- TxSkelOut -> Maybe (Versioned Validator)
txSkelOutValidator TxSkelOut
txSkelOut
      (ScriptHash, Versioned Script)
-> Maybe (ScriptHash, Versioned Script)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Versioned Validator -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
Script.toScriptHash Versioned Validator
val, forall s a. ToVersioned s a => a -> Versioned s
Script.toVersioned @Script.Script Versioned Validator
val)

-- | Collects the datums paid in an 'InitialDistribution'
datumMap0From :: InitialDistribution -> Map Api.DatumHash (TxSkelOutDatum, Integer)
datumMap0From :: InitialDistribution -> Map DatumHash (TxSkelOutDatum, Integer)
datumMap0From (InitialDistribution [TxSkelOut]
initDist) =
  -- This concatenates singleton maps from inputs and accounts for the number of
  -- occurrences of similar datums
  (Map DatumHash (TxSkelOutDatum, Integer)
 -> TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer))
-> Map DatumHash (TxSkelOutDatum, Integer)
-> [TxSkelOut]
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map DatumHash (TxSkelOutDatum, Integer)
m -> ((TxSkelOutDatum, Integer)
 -> (TxSkelOutDatum, Integer) -> (TxSkelOutDatum, Integer))
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\(TxSkelOutDatum
d, Integer
n1) (TxSkelOutDatum
_, Integer
n2) -> (TxSkelOutDatum
d, Integer
n1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n2)) Map DatumHash (TxSkelOutDatum, Integer)
m (Map DatumHash (TxSkelOutDatum, Integer)
 -> Map DatumHash (TxSkelOutDatum, Integer))
-> (TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer))
-> TxSkelOut
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer)
unitMapFrom) Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Map k a
Map.empty [TxSkelOut]
initDist
  where
    -- This takes a single output and creates an empty map if it contains no
    -- datum, or a singleton map if it contains one
    unitMapFrom :: TxSkelOut -> Map Api.DatumHash (TxSkelOutDatum, Integer)
    unitMapFrom :: TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer)
unitMapFrom TxSkelOut
txSkelOut =
      let datum :: TxSkelOutDatum
datum = Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
-> TxSkelOut -> TxSkelOutDatum
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
txSkelOutDatumL TxSkelOut
txSkelOut
       in Map DatumHash (TxSkelOutDatum, Integer)
-> (Datum -> Map DatumHash (TxSkelOutDatum, Integer))
-> Maybe Datum
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Map k a
Map.empty ((DatumHash
 -> (TxSkelOutDatum, Integer)
 -> Map DatumHash (TxSkelOutDatum, Integer))
-> (TxSkelOutDatum, Integer)
-> DatumHash
-> Map DatumHash (TxSkelOutDatum, Integer)
forall a b c. (a -> b -> c) -> b -> a -> c
flip DatumHash
-> (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
forall k a. k -> a -> Map k a
Map.singleton (TxSkelOutDatum
datum, Integer
1) (DatumHash -> Map DatumHash (TxSkelOutDatum, Integer))
-> (Datum -> DatumHash)
-> Datum
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Datum -> DatumHash
Script.datumHash) (Maybe Datum -> Map DatumHash (TxSkelOutDatum, Integer))
-> Maybe Datum -> Map DatumHash (TxSkelOutDatum, Integer)
forall a b. (a -> b) -> a -> b
$ TxSkelOutDatum -> Maybe Datum
txSkelOutUntypedDatum TxSkelOutDatum
datum

-- | This creates the initial UtxoIndex from an initial distribution by
-- submitting an initial transaction with the appropriate content:
--
-- - inputs consist of a single dummy pseudo input
--
-- - outputs are translated from the `TxSkelOut` list in the initial
--   distribution
--
-- Two things to note:
--
-- - We don't know what "Magic" means for the network ID (TODO)
--
-- - The genesis key hash has been taken from
--   https://github.com/input-output-hk/cardano-node/blob/543b267d75d3d448e1940f9ec04b42bd01bbb16b/cardano-api/test/Test/Cardano/Api/Genesis.hs#L60
utxoIndex0From :: (MonadBlockChainBalancing m) => InitialDistribution -> m Ledger.UtxoIndex
utxoIndex0From :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m UtxoIndex
utxoIndex0From (InitialDistribution [TxSkelOut]
initDist) = do
  NetworkId
networkId <- Params -> NetworkId
Emulator.pNetworkId (Params -> NetworkId) -> m Params -> m NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  let genesisKeyHash :: Hash GenesisUTxOKey
genesisKeyHash = KeyHash 'Payment -> Hash GenesisUTxOKey
Cardano.GenesisUTxOKeyHash (KeyHash 'Payment -> Hash GenesisUTxOKey)
-> KeyHash 'Payment -> Hash GenesisUTxOKey
forall a b. (a -> b) -> a -> b
$ Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash 'Payment
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
Shelley.KeyHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
"23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194"
      inputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
inputs = [(NetworkId -> Hash GenesisUTxOKey -> TxIn
Cardano.genesisUTxOPseudoTxIn NetworkId
networkId Hash GenesisUTxOKey
genesisKeyHash, Witness WitCtxTxIn ConwayEra
-> BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra)
forall a. a -> BuildTxWith BuildTx a
Cardano.BuildTxWith (Witness WitCtxTxIn ConwayEra
 -> BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))
-> Witness WitCtxTxIn ConwayEra
-> BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn ConwayEra
forall witctx era. KeyWitnessInCtx witctx -> Witness witctx era
Cardano.KeyWitness KeyWitnessInCtx WitCtxTxIn
Cardano.KeyWitnessForSpending)]
  [TxOut CtxTx ConwayEra]
outputs <- (TxSkelOut -> m (TxOut CtxTx ConwayEra))
-> [TxSkelOut] -> m [TxOut CtxTx ConwayEra]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TxSkelOut -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m TxSkelOut
toTxSkelOutWithMinAda (TxSkelOut -> m TxSkelOut)
-> (TxSkelOut -> m (TxOut CtxTx ConwayEra))
-> TxSkelOut
-> m (TxOut CtxTx ConwayEra)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TxSkelOut -> m (TxOut CtxTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m (TxOut CtxTx ConwayEra)
toCardanoTxOut) [TxSkelOut]
initDist
  Blockchain -> UtxoIndex
Ledger.initialise (Blockchain -> UtxoIndex)
-> (TxBody ConwayEra -> Blockchain)
-> TxBody ConwayEra
-> UtxoIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([OnChainTx] -> Blockchain -> Blockchain
forall a. a -> [a] -> [a]
: []) ([OnChainTx] -> Blockchain)
-> (TxBody ConwayEra -> [OnChainTx])
-> TxBody ConwayEra
-> Blockchain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OnChainTx -> [OnChainTx] -> [OnChainTx]
forall a. a -> [a] -> [a]
: []) (OnChainTx -> [OnChainTx])
-> (TxBody ConwayEra -> OnChainTx)
-> TxBody ConwayEra
-> [OnChainTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> OnChainTx
Emulator.unsafeMakeValid (CardanoTx -> OnChainTx)
-> (TxBody ConwayEra -> CardanoTx) -> TxBody ConwayEra -> OnChainTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx ConwayEra -> CardanoTx
Ledger.CardanoEmulatorEraTx (Tx ConwayEra -> CardanoTx)
-> (TxBody ConwayEra -> Tx ConwayEra)
-> TxBody ConwayEra
-> CardanoTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Wallet] -> TxBody ConwayEra -> Tx ConwayEra
txSignersAndBodyToCardanoTx []
    (TxBody ConwayEra -> UtxoIndex)
-> m (TxBody ConwayEra) -> m UtxoIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TxBodyError -> m (TxBody ConwayEra))
-> (TxBody ConwayEra -> m (TxBody ConwayEra))
-> Either TxBodyError (TxBody ConwayEra)
-> m (TxBody ConwayEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (MockChainError -> m (TxBody ConwayEra)
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m (TxBody ConwayEra))
-> (TxBodyError -> MockChainError)
-> TxBodyError
-> m (TxBody ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenerateTxError -> MockChainError
MCEGenerationError (GenerateTxError -> MockChainError)
-> (TxBodyError -> GenerateTxError)
-> TxBodyError
-> MockChainError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TxBodyError -> GenerateTxError
TxBodyError String
"generateTx :")
      TxBody ConwayEra -> m (TxBody ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( ShelleyBasedEra ConwayEra
-> TxBodyContent BuildTx ConwayEra
-> Either TxBodyError (TxBody ConwayEra)
forall era.
HasCallStack =>
ShelleyBasedEra era
-> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
Cardano.createTransactionBody
          ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway
          (TxBodyContent BuildTx ConwayEra
Ledger.emptyTxBodyContent {Cardano.txOuts = outputs, Cardano.txIns = inputs})
      )

-- | Same as 'utxoIndex0From' with the default 'InitialDistribution'
utxoIndex0 :: (MonadBlockChainBalancing m) => m Ledger.UtxoIndex
utxoIndex0 :: forall (m :: * -> *). MonadBlockChainBalancing m => m UtxoIndex
utxoIndex0 = InitialDistribution -> m UtxoIndex
forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m UtxoIndex
utxoIndex0From InitialDistribution
forall a. Default a => a
def