-- | This module allows the generation of Cardano reference inputs
module Cooked.MockChain.GenerateTx.ReferenceInputs (toInsReference) where

import Cardano.Api qualified as Cardano
import Cooked.MockChain.Read
import Cooked.Skeleton
import Data.Map qualified as Map
import Data.Set qualified as Set
import Ledger.Tx.CardanoAPI qualified as Ledger
import PlutusLedgerApi.V3 qualified as Api
import Polysemy
import Polysemy.Error

-- | Takes a 'TxSkel' and generates the associated 'Cardano.TxInsReference' from
-- its content. These reference inputs can be found in two places, either in
-- direct reference inputs 'txSkelInsReference' or scattered in the various
-- redeemers of the transaction, which can be gathered with
-- 'txSkelInsReferenceInRedeemers'.
toInsReference ::
  (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) =>
  TxSkel ->
  Sem effs (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra)
toInsReference :: forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkel -> Sem effs (TxInsReference BuildTx ConwayEra)
toInsReference TxSkel
skel = do
  -- As regular inputs can be used to hold scripts as if in reference inputs, we
  -- need to remove from the reference inputs stored in redeemers the ones that
  -- already appear in the inputs to avoid validation errors.
  let indirectReferenceInputs :: Set TxOutRef
indirectReferenceInputs = TxSkel -> Set TxOutRef
txSkelInsReferenceInRedeemers TxSkel
skel
      redundantReferenceInputs :: Set TxOutRef
redundantReferenceInputs = Set TxOutRef
indirectReferenceInputs Set TxOutRef -> Set TxOutRef -> Set TxOutRef
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Map TxOutRef TxSkelRedeemer -> Set TxOutRef
forall k a. Map k a -> Set k
Map.keysSet (TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelIns TxSkel
skel)
      refInputs :: [TxOutRef]
refInputs = Set TxOutRef -> [TxOutRef]
forall a. Set a -> [a]
Set.toList (TxSkel -> Set TxOutRef
txSkelInsReference TxSkel
skel Set TxOutRef -> Set TxOutRef -> Set TxOutRef
forall a. Semigroup a => a -> a -> a
<> Set TxOutRef
indirectReferenceInputs Set TxOutRef -> Set TxOutRef -> Set TxOutRef
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set TxOutRef
redundantReferenceInputs)
  if [TxOutRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxOutRef]
refInputs
    then TxInsReference BuildTx ConwayEra
-> Sem effs (TxInsReference BuildTx ConwayEra)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return TxInsReference BuildTx ConwayEra
forall build era. TxInsReference build era
Cardano.TxInsReferenceNone
    else do
      [TxIn]
cardanoRefInputs <- Either ToCardanoError [TxIn] -> Sem effs [TxIn]
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither (Either ToCardanoError [TxIn] -> Sem effs [TxIn])
-> Either ToCardanoError [TxIn] -> Sem effs [TxIn]
forall a b. (a -> b) -> a -> b
$ (TxOutRef -> Either ToCardanoError TxIn)
-> [TxOutRef] -> Either ToCardanoError [TxIn]
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 TxOutRef -> Either ToCardanoError TxIn
Ledger.toCardanoTxIn [TxOutRef]
refInputs
      [TxSkelOutDatum]
resolvedDatums <- (TxOutRef -> Sem effs TxSkelOutDatum)
-> [TxOutRef] -> Sem effs [TxSkelOutDatum]
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 (Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
-> TxOutRef -> Sem effs TxSkelOutDatum
forall (effs :: EffectRow) g (is :: IxList) c.
(Member MockChainRead effs, Is g A_Getter) =>
Optic' g is TxSkelOut c -> TxOutRef -> Sem effs c
viewByRef Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
txSkelOutDatumL) [TxOutRef]
refInputs
      TxInsReference BuildTx ConwayEra
-> Sem effs (TxInsReference BuildTx ConwayEra)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxInsReference BuildTx ConwayEra
 -> Sem effs (TxInsReference BuildTx ConwayEra))
-> TxInsReference BuildTx ConwayEra
-> Sem effs (TxInsReference BuildTx ConwayEra)
forall a b. (a -> b) -> a -> b
$
        BabbageEraOnwards ConwayEra
-> [TxIn]
-> TxInsReferenceDatums BuildTx
-> TxInsReference BuildTx ConwayEra
forall era build.
BabbageEraOnwards era
-> [TxIn] -> TxInsReferenceDatums build -> TxInsReference build era
Cardano.TxInsReference BabbageEraOnwards ConwayEra
Cardano.BabbageEraOnwardsConway [TxIn]
cardanoRefInputs (TxInsReferenceDatums BuildTx -> TxInsReference BuildTx ConwayEra)
-> TxInsReferenceDatums BuildTx -> TxInsReference BuildTx ConwayEra
forall a b. (a -> b) -> a -> b
$
          Set HashableScriptData -> TxInsReferenceDatums BuildTx
forall a. a -> BuildTxWith BuildTx a
Cardano.BuildTxWith (Set HashableScriptData -> TxInsReferenceDatums BuildTx)
-> Set HashableScriptData -> TxInsReferenceDatums BuildTx
forall a b. (a -> b) -> a -> b
$
            [HashableScriptData] -> Set HashableScriptData
forall a. Ord a => [a] -> Set a
Set.fromList
              [BuiltinData -> HashableScriptData
Ledger.toCardanoScriptData (BuiltinData -> HashableScriptData)
-> BuiltinData -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ dat -> BuiltinData
forall a. ToData a => a -> BuiltinData
Api.toBuiltinData dat
dat | SomeTxSkelOutDatum dat
dat (Hashed DatumResolved
_) <- [TxSkelOutDatum]
resolvedDatums]