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

module Cardano.Api.Internal.Experimental.Witness.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.Internal.Eon.AlonzoEraOnwards
import Cardano.Api.Internal.Eon.Convert (Convert (convert))
import Cardano.Api.Internal.Eon.ShelleyBasedEra
import Cardano.Api.Internal.Experimental.Plutus.IndexedPlutusScriptWitness
import Cardano.Api.Internal.Experimental.Witness.AnyWitness
import Cardano.Api.Internal.Script (ExecutionUnits, fromAlonzoExUnits)
import Cardano.Api.Ledger qualified as L

import Cardano.Ledger.Alonzo.TxWits qualified as L
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

getTxScriptWitnessRequirements
  :: AlonzoEraOnwards era
  -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))]
  -> TxScriptWitnessRequirements (ShelleyLedgerEra era)
getTxScriptWitnessRequirements :: forall era (witnessable :: WitnessableItem).
AlonzoEraOnwards era
-> [(Witnessable witnessable (ShelleyLedgerEra era),
     AnyWitness (ShelleyLedgerEra era))]
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
getTxScriptWitnessRequirements AlonzoEraOnwards era
era [(Witnessable witnessable (ShelleyLedgerEra era),
  AnyWitness (ShelleyLedgerEra era))]
wits =
  let TxScriptWitnessRequirements Set Language
l [Script (ShelleyLedgerEra era)]
s TxDats (ShelleyLedgerEra era)
d Redeemers (ShelleyLedgerEra era)
_ =
        AlonzoEraOnwards era
-> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
    TxScriptWitnessRequirements (ShelleyLedgerEra era))
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
forall era a.
AlonzoEraOnwards era
-> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
    a)
-> a
obtainMonoidConstraint AlonzoEraOnwards era
era ((Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
  TxScriptWitnessRequirements (ShelleyLedgerEra era))
 -> TxScriptWitnessRequirements (ShelleyLedgerEra era))
-> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
    TxScriptWitnessRequirements (ShelleyLedgerEra era))
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
forall a b. (a -> b) -> a -> b
$
          [TxScriptWitnessRequirements (ShelleyLedgerEra era)]
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
forall a. Monoid a => [a] -> a
mconcat
            [ Set Language
-> [Script (ShelleyLedgerEra era)]
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxScriptWitnessRequirements (ShelleyLedgerEra 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 (ShelleyLedgerEra era) -> Maybe Language
forall era. AnyWitness era -> Maybe Language
getAnyWitnessPlutusLanguage AnyWitness (ShelleyLedgerEra era)
anyWit)
                ([Script (ShelleyLedgerEra era)]
-> (Script (ShelleyLedgerEra era)
    -> [Script (ShelleyLedgerEra era)])
-> Maybe (Script (ShelleyLedgerEra era))
-> [Script (ShelleyLedgerEra era)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Script (ShelleyLedgerEra era)]
forall a. Monoid a => a
mempty Script (ShelleyLedgerEra era) -> [Script (ShelleyLedgerEra era)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Script (ShelleyLedgerEra era))
 -> [Script (ShelleyLedgerEra era)])
-> Maybe (Script (ShelleyLedgerEra era))
-> [Script (ShelleyLedgerEra era)]
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> AnyWitness (ShelleyLedgerEra era)
-> Maybe (Script (ShelleyLedgerEra era))
forall era.
ShelleyBasedEra era
-> AnyWitness (ShelleyLedgerEra era)
-> Maybe (Script (ShelleyLedgerEra era))
getAnyWitnessScript (AlonzoEraOnwards era -> ShelleyBasedEra era
forall era. AlonzoEraOnwards era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert AlonzoEraOnwards era
era) AnyWitness (ShelleyLedgerEra era)
anyWit)
                (AlonzoEraOnwards era
-> AnyWitness (ShelleyLedgerEra era)
-> TxDats (ShelleyLedgerEra era)
forall era.
AlonzoEraOnwards era
-> AnyWitness (ShelleyLedgerEra era)
-> TxDats (ShelleyLedgerEra era)
getAnyWitnessScriptData AlonzoEraOnwards era
era AnyWitness (ShelleyLedgerEra era)
anyWit)
                (AlonzoEraOnwards era
-> (AlonzoEraOnwardsConstraints era =>
    Redeemers (ShelleyLedgerEra era))
-> Redeemers (ShelleyLedgerEra era)
forall era a.
AlonzoEraOnwards era -> (AlonzoEraOnwardsConstraints era => a) -> a
alonzoEraOnwardsConstraints AlonzoEraOnwards era
era Redeemers (ShelleyLedgerEra era)
AlonzoEraOnwardsConstraints era => Redeemers (ShelleyLedgerEra era)
forall a. Monoid a => a
mempty)
            | (Witnessable witnessable (ShelleyLedgerEra era)
_, AnyWitness (ShelleyLedgerEra era)
anyWit) <- [(Witnessable witnessable (ShelleyLedgerEra era),
  AnyWitness (ShelleyLedgerEra era))]
wits
            ]
   in Set Language
-> [Script (ShelleyLedgerEra era)]
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
forall era.
Set Language
-> [Script era]
-> TxDats era
-> Redeemers era
-> TxScriptWitnessRequirements era
TxScriptWitnessRequirements Set Language
l [Script (ShelleyLedgerEra era)]
s TxDats (ShelleyLedgerEra era)
d (AlonzoEraOnwards era
-> [(Witnessable witnessable (ShelleyLedgerEra era),
     AnyWitness (ShelleyLedgerEra era))]
-> Redeemers (ShelleyLedgerEra era)
forall era (witnessable :: WitnessableItem).
AlonzoEraOnwards era
-> [(Witnessable witnessable (ShelleyLedgerEra era),
     AnyWitness (ShelleyLedgerEra era))]
-> Redeemers (ShelleyLedgerEra era)
getAnyWitnessRedeemerPointerMap AlonzoEraOnwards era
era [(Witnessable witnessable (ShelleyLedgerEra era),
  AnyWitness (ShelleyLedgerEra era))]
wits)

getTxScriptWitnessesRequirements
  :: AlonzoEraOnwards era
  -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))]
  -> TxScriptWitnessRequirements (ShelleyLedgerEra era)
getTxScriptWitnessesRequirements :: forall era (witnessable :: WitnessableItem).
AlonzoEraOnwards era
-> [(Witnessable witnessable (ShelleyLedgerEra era),
     AnyWitness (ShelleyLedgerEra era))]
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
getTxScriptWitnessesRequirements AlonzoEraOnwards era
eon [(Witnessable witnessable (ShelleyLedgerEra era),
  AnyWitness (ShelleyLedgerEra era))]
wits =
  AlonzoEraOnwards era
-> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
    TxScriptWitnessRequirements (ShelleyLedgerEra era))
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
forall era a.
AlonzoEraOnwards era
-> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
    a)
-> a
obtainMonoidConstraint AlonzoEraOnwards era
eon ((Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
  TxScriptWitnessRequirements (ShelleyLedgerEra era))
 -> TxScriptWitnessRequirements (ShelleyLedgerEra era))
-> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
    TxScriptWitnessRequirements (ShelleyLedgerEra era))
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
forall a b. (a -> b) -> a -> b
$ AlonzoEraOnwards era
-> [(Witnessable witnessable (ShelleyLedgerEra era),
     AnyWitness (ShelleyLedgerEra era))]
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
forall era (witnessable :: WitnessableItem).
AlonzoEraOnwards era
-> [(Witnessable witnessable (ShelleyLedgerEra era),
     AnyWitness (ShelleyLedgerEra era))]
-> TxScriptWitnessRequirements (ShelleyLedgerEra era)
getTxScriptWitnessRequirements AlonzoEraOnwards era
eon [(Witnessable witnessable (ShelleyLedgerEra era),
  AnyWitness (ShelleyLedgerEra era))]
wits

obtainMonoidConstraint
  :: AlonzoEraOnwards era
  -> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) => a)
  -> a
obtainMonoidConstraint :: forall era a.
AlonzoEraOnwards era
-> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) =>
    a)
-> a
obtainMonoidConstraint AlonzoEraOnwards era
eon = case AlonzoEraOnwards era
eon of
  AlonzoEraOnwards era
AlonzoEraOnwardsAlonzo -> a -> a
(Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) => a)
-> a
forall a. a -> a
id
  AlonzoEraOnwards era
AlonzoEraOnwardsBabbage -> a -> a
(Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) => a)
-> a
forall a. a -> a
id
  AlonzoEraOnwards era
AlonzoEraOnwardsConway -> a -> a
(Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra 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]