{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
  ( -- * All the parts that constitute a plutus script witness but also including simple scripts
    TxScriptWitnessRequirements (..)

    -- * Collecting plutus script witness related transaction requirements.
  , getTxScriptWitnessesRequirements
  , obtainMonoidConstraint

    -- * For testing only
  , extractExecutionUnits
  , getTxScriptWitnessRequirements
  )
where

import Cardano.Api.Experimental.Era qualified as Exp
import Cardano.Api.Experimental.Plutus.Internal.IndexedPlutusScriptWitness
import Cardano.Api.Experimental.Tx.Internal.AnyWitness
import Cardano.Api.Ledger qualified as L
import Cardano.Api.Plutus.Internal.Script (ExecutionUnits, fromAlonzoExUnits)

import Cardano.Ledger.Api.Era as L

import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set

-- | This type collects all the requirements for script witnesses in a transaction.
data TxScriptWitnessRequirements era
  = TxScriptWitnessRequirements
      (Set L.Language)
      [L.Script era]
      (L.TxDats era)
      (L.Redeemers era)

instance Semigroup (TxScriptWitnessRequirements L.AlonzoEra) where
  <> :: TxScriptWitnessRequirements AlonzoEra
-> TxScriptWitnessRequirements AlonzoEra
-> TxScriptWitnessRequirements AlonzoEra
(<>) (TxScriptWitnessRequirements Set Language
l1 [Script AlonzoEra]
s1 TxDats AlonzoEra
d1 Redeemers AlonzoEra
r1) (TxScriptWitnessRequirements Set Language
l2 [Script AlonzoEra]
s2 TxDats AlonzoEra
d2 Redeemers AlonzoEra
r2) =
    Set Language
-> [Script AlonzoEra]
-> TxDats AlonzoEra
-> Redeemers AlonzoEra
-> TxScriptWitnessRequirements AlonzoEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements (Set Language
l1 Set Language -> Set Language -> Set Language
forall a. Semigroup a => a -> a -> a
<> Set Language
l2) ([Script AlonzoEra]
[AlonzoScript AlonzoEra]
s1 [AlonzoScript AlonzoEra]
-> [AlonzoScript AlonzoEra] -> [AlonzoScript AlonzoEra]
forall a. Semigroup a => a -> a -> a
<> [Script AlonzoEra]
[AlonzoScript AlonzoEra]
s2) (TxDats AlonzoEra
d1 TxDats AlonzoEra -> TxDats AlonzoEra -> TxDats AlonzoEra
forall a. Semigroup a => a -> a -> a
<> TxDats AlonzoEra
d2) (Redeemers AlonzoEra
r1 Redeemers AlonzoEra -> Redeemers AlonzoEra -> Redeemers AlonzoEra
forall a. Semigroup a => a -> a -> a
<> Redeemers AlonzoEra
r2)

instance Monoid (TxScriptWitnessRequirements L.AlonzoEra) where
  mempty :: TxScriptWitnessRequirements AlonzoEra
mempty = Set Language
-> [Script AlonzoEra]
-> TxDats AlonzoEra
-> Redeemers AlonzoEra
-> TxScriptWitnessRequirements AlonzoEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements Set Language
forall a. Monoid a => a
mempty [Script AlonzoEra]
[AlonzoScript AlonzoEra]
forall a. Monoid a => a
mempty TxDats AlonzoEra
forall a. Monoid a => a
mempty Redeemers AlonzoEra
forall a. Monoid a => a
mempty

instance Semigroup (TxScriptWitnessRequirements L.BabbageEra) where
  <> :: TxScriptWitnessRequirements BabbageEra
-> TxScriptWitnessRequirements BabbageEra
-> TxScriptWitnessRequirements BabbageEra
(<>) (TxScriptWitnessRequirements Set Language
l1 [Script BabbageEra]
s1 TxDats BabbageEra
d1 Redeemers BabbageEra
r1) (TxScriptWitnessRequirements Set Language
l2 [Script BabbageEra]
s2 TxDats BabbageEra
d2 Redeemers BabbageEra
r2) =
    Set Language
-> [Script BabbageEra]
-> TxDats BabbageEra
-> Redeemers BabbageEra
-> TxScriptWitnessRequirements BabbageEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements (Set Language
l1 Set Language -> Set Language -> Set Language
forall a. Semigroup a => a -> a -> a
<> Set Language
l2) ([Script BabbageEra]
[AlonzoScript BabbageEra]
s1 [AlonzoScript BabbageEra]
-> [AlonzoScript BabbageEra] -> [AlonzoScript BabbageEra]
forall a. Semigroup a => a -> a -> a
<> [Script BabbageEra]
[AlonzoScript BabbageEra]
s2) (TxDats BabbageEra
d1 TxDats BabbageEra -> TxDats BabbageEra -> TxDats BabbageEra
forall a. Semigroup a => a -> a -> a
<> TxDats BabbageEra
d2) (Redeemers BabbageEra
r1 Redeemers BabbageEra
-> Redeemers BabbageEra -> Redeemers BabbageEra
forall a. Semigroup a => a -> a -> a
<> Redeemers BabbageEra
r2)

instance Monoid (TxScriptWitnessRequirements L.BabbageEra) where
  mempty :: TxScriptWitnessRequirements BabbageEra
mempty = Set Language
-> [Script BabbageEra]
-> TxDats BabbageEra
-> Redeemers BabbageEra
-> TxScriptWitnessRequirements BabbageEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements Set Language
forall a. Monoid a => a
mempty [Script BabbageEra]
[AlonzoScript BabbageEra]
forall a. Monoid a => a
mempty TxDats BabbageEra
forall a. Monoid a => a
mempty Redeemers BabbageEra
forall a. Monoid a => a
mempty

instance Semigroup (TxScriptWitnessRequirements L.ConwayEra) where
  <> :: TxScriptWitnessRequirements ConwayEra
-> TxScriptWitnessRequirements ConwayEra
-> TxScriptWitnessRequirements ConwayEra
(<>) (TxScriptWitnessRequirements Set Language
l1 [Script ConwayEra]
s1 TxDats ConwayEra
d1 Redeemers ConwayEra
r1) (TxScriptWitnessRequirements Set Language
l2 [Script ConwayEra]
s2 TxDats ConwayEra
d2 Redeemers ConwayEra
r2) =
    Set Language
-> [Script ConwayEra]
-> TxDats ConwayEra
-> Redeemers ConwayEra
-> TxScriptWitnessRequirements ConwayEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements (Set Language
l1 Set Language -> Set Language -> Set Language
forall a. Semigroup a => a -> a -> a
<> Set Language
l2) ([Script ConwayEra]
[AlonzoScript ConwayEra]
s1 [AlonzoScript ConwayEra]
-> [AlonzoScript ConwayEra] -> [AlonzoScript ConwayEra]
forall a. Semigroup a => a -> a -> a
<> [Script ConwayEra]
[AlonzoScript ConwayEra]
s2) (TxDats ConwayEra
d1 TxDats ConwayEra -> TxDats ConwayEra -> TxDats ConwayEra
forall a. Semigroup a => a -> a -> a
<> TxDats ConwayEra
d2) (Redeemers ConwayEra
r1 Redeemers ConwayEra -> Redeemers ConwayEra -> Redeemers ConwayEra
forall a. Semigroup a => a -> a -> a
<> Redeemers ConwayEra
r2)

instance Monoid (TxScriptWitnessRequirements L.ConwayEra) where
  mempty :: TxScriptWitnessRequirements ConwayEra
mempty = Set Language
-> [Script ConwayEra]
-> TxDats ConwayEra
-> Redeemers ConwayEra
-> TxScriptWitnessRequirements ConwayEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements Set Language
forall a. Monoid a => a
mempty [Script ConwayEra]
[AlonzoScript ConwayEra]
forall a. Monoid a => a
mempty TxDats ConwayEra
forall a. Monoid a => a
mempty Redeemers ConwayEra
forall a. Monoid a => a
mempty

instance Semigroup (TxScriptWitnessRequirements L.DijkstraEra) where
  <> :: TxScriptWitnessRequirements DijkstraEra
-> TxScriptWitnessRequirements DijkstraEra
-> TxScriptWitnessRequirements DijkstraEra
(<>) (TxScriptWitnessRequirements Set Language
l1 [Script DijkstraEra]
s1 TxDats DijkstraEra
d1 Redeemers DijkstraEra
r1) (TxScriptWitnessRequirements Set Language
l2 [Script DijkstraEra]
s2 TxDats DijkstraEra
d2 Redeemers DijkstraEra
r2) =
    Set Language
-> [Script DijkstraEra]
-> TxDats DijkstraEra
-> Redeemers DijkstraEra
-> TxScriptWitnessRequirements DijkstraEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements (Set Language
l1 Set Language -> Set Language -> Set Language
forall a. Semigroup a => a -> a -> a
<> Set Language
l2) ([Script DijkstraEra]
[AlonzoScript DijkstraEra]
s1 [AlonzoScript DijkstraEra]
-> [AlonzoScript DijkstraEra] -> [AlonzoScript DijkstraEra]
forall a. Semigroup a => a -> a -> a
<> [Script DijkstraEra]
[AlonzoScript DijkstraEra]
s2) (TxDats DijkstraEra
d1 TxDats DijkstraEra -> TxDats DijkstraEra -> TxDats DijkstraEra
forall a. Semigroup a => a -> a -> a
<> TxDats DijkstraEra
d2) (Redeemers DijkstraEra
r1 Redeemers DijkstraEra
-> Redeemers DijkstraEra -> Redeemers DijkstraEra
forall a. Semigroup a => a -> a -> a
<> Redeemers DijkstraEra
r2)

instance Monoid (TxScriptWitnessRequirements L.DijkstraEra) where
  mempty :: TxScriptWitnessRequirements DijkstraEra
mempty = Set Language
-> [Script DijkstraEra]
-> TxDats DijkstraEra
-> Redeemers DijkstraEra
-> TxScriptWitnessRequirements DijkstraEra
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements Set Language
forall a. Monoid a => a
mempty [Script DijkstraEra]
[AlonzoScript DijkstraEra]
forall a. Monoid a => a
mempty TxDats DijkstraEra
forall a. Monoid a => a
mempty Redeemers DijkstraEra
forall a. Monoid a => a
mempty

getTxScriptWitnessRequirements
  :: L.AlonzoEraScript era
  => Monoid (TxScriptWitnessRequirements era)
  => [(Witnessable witnessable era, AnyWitness era)]
  -> TxScriptWitnessRequirements era
getTxScriptWitnessRequirements :: forall era (witnessable :: WitnessableItem).
(AlonzoEraScript era, Monoid (TxScriptWitnessRequirements era)) =>
[(Witnessable witnessable era, AnyWitness era)]
-> TxScriptWitnessRequirements era
getTxScriptWitnessRequirements [(Witnessable witnessable era, AnyWitness era)]
wits =
  let TxScriptWitnessRequirements Set Language
l [Script era]
s TxDats era
d Redeemers era
_ =
        [TxScriptWitnessRequirements era]
-> TxScriptWitnessRequirements era
forall a. Monoid a => [a] -> a
mconcat
          [ Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements
              (Set Language
-> (Language -> Set Language) -> Maybe Language -> Set Language
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Language
forall a. Monoid a => a
mempty Language -> Set Language
forall a. a -> Set a
Set.singleton (Maybe Language -> Set Language) -> Maybe Language -> Set Language
forall a b. (a -> b) -> a -> b
$ AnyWitness era -> Maybe Language
forall era. AnyWitness era -> Maybe Language
getAnyWitnessPlutusLanguage AnyWitness era
anyWit)
              ([Script era]
-> (Script era -> [Script era])
-> Maybe (Script era)
-> [Script era]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Script era]
forall a. Monoid a => a
mempty Script era -> [Script era]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Script era) -> [Script era])
-> Maybe (Script era) -> [Script era]
forall a b. (a -> b) -> a -> b
$ AnyWitness era -> Maybe (Script era)
forall era.
AlonzoEraScript era =>
AnyWitness era -> Maybe (Script era)
getAnyWitnessScript AnyWitness era
anyWit)
              (AnyWitness era -> TxDats era
forall era. Era era => AnyWitness era -> TxDats era
getAnyWitnessScriptData AnyWitness era
anyWit)
              Redeemers era
forall a. Monoid a => a
mempty
          | (Witnessable witnessable era
_, AnyWitness era
anyWit) <- [(Witnessable witnessable era, AnyWitness era)]
wits
          ]
   in Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements Set Language
l [Script era]
s TxDats era
d ([(Witnessable witnessable era, AnyWitness era)] -> Redeemers era
forall era (witnessable :: WitnessableItem).
AlonzoEraScript era =>
[(Witnessable witnessable era, AnyWitness era)] -> Redeemers era
getAnyWitnessRedeemerPointerMap [(Witnessable witnessable era, AnyWitness era)]
wits)

getTxScriptWitnessesRequirements
  :: L.AlonzoEraScript era
  => Monoid (TxScriptWitnessRequirements era)
  => [(Witnessable witnessable era, AnyWitness era)]
  -> TxScriptWitnessRequirements era
getTxScriptWitnessesRequirements :: forall era (witnessable :: WitnessableItem).
(AlonzoEraScript era, Monoid (TxScriptWitnessRequirements era)) =>
[(Witnessable witnessable era, AnyWitness era)]
-> TxScriptWitnessRequirements era
getTxScriptWitnessesRequirements [(Witnessable witnessable era, AnyWitness era)]
wits =
  [(Witnessable witnessable era, AnyWitness era)]
-> TxScriptWitnessRequirements era
forall era (witnessable :: WitnessableItem).
(AlonzoEraScript era, Monoid (TxScriptWitnessRequirements era)) =>
[(Witnessable witnessable era, AnyWitness era)]
-> TxScriptWitnessRequirements era
getTxScriptWitnessRequirements [(Witnessable witnessable era, AnyWitness era)]
wits

obtainMonoidConstraint
  :: Exp.Era era
  -> (Monoid (TxScriptWitnessRequirements (Exp.LedgerEra era)) => a)
  -> a
obtainMonoidConstraint :: forall era a.
Era era
-> (Monoid (TxScriptWitnessRequirements (LedgerEra era)) => a) -> a
obtainMonoidConstraint Era era
eon = case Era era
eon of
  Era era
Exp.ConwayEra -> a -> a
(Monoid (TxScriptWitnessRequirements (LedgerEra era)) => a) -> a
forall a. a -> a
id
  Era era
Exp.DijkstraEra -> a -> a
(Monoid (TxScriptWitnessRequirements (LedgerEra era)) => a) -> a
forall a. a -> a
id

extractExecutionUnits :: TxScriptWitnessRequirements era -> [ExecutionUnits]
extractExecutionUnits :: forall era. TxScriptWitnessRequirements era -> [ExecutionUnits]
extractExecutionUnits (TxScriptWitnessRequirements Set Language
_ [Script era]
_ TxDats era
_ Redeemers era
redeemers) =
  let m :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
m = Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
L.unRedeemers Redeemers era
redeemers
   in [ExUnits -> ExecutionUnits
fromAlonzoExUnits ExUnits
exUnits | (Data era
_, ExUnits
exUnits) <- Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> [(Data era, ExUnits)]
forall k a. Map k a -> [a]
Map.elems Map (PlutusPurpose AsIx era) (Data era, ExUnits)
m]