{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Figure 3: Functions related to scripts
--   Babbage Specification
module Cardano.Ledger.Babbage.Scripts (
  AlonzoScript (..),
  isPlutusScript,
  PlutusScript (..),
)
where

import Cardano.Ledger.Allegra.Scripts
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Scripts (
  AlonzoPlutusPurpose (..),
  AlonzoScript (..),
  PlutusScript (..),
  alonzoScriptPrefixTag,
  isPlutusScript,
 )
import Cardano.Ledger.Babbage.Era
import Cardano.Ledger.Babbage.TxCert ()
import Cardano.Ledger.Plutus.Language
import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..))
import Control.DeepSeq (NFData (..), rwhnf)
import Data.MemPack
import GHC.Generics
import NoThunks.Class (NoThunks (..))

instance EraScript BabbageEra where
  type Script BabbageEra = AlonzoScript BabbageEra
  type NativeScript BabbageEra = Timelock BabbageEra

  upgradeScript :: EraScript (PreviousEra BabbageEra) =>
Script (PreviousEra BabbageEra) -> Script BabbageEra
upgradeScript = \case
    TimelockScript Timelock AlonzoEra
ts -> forall era. Timelock era -> AlonzoScript era
TimelockScript forall a b. (a -> b) -> a -> b
$ forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock Timelock AlonzoEra
ts
    PlutusScript (AlonzoPlutusV1 Plutus 'PlutusV1
ps) -> forall era. PlutusScript era -> AlonzoScript era
PlutusScript forall a b. (a -> b) -> a -> b
$ Plutus 'PlutusV1 -> PlutusScript BabbageEra
BabbagePlutusV1 Plutus 'PlutusV1
ps

  scriptPrefixTag :: Script BabbageEra -> ByteString
scriptPrefixTag = forall era.
(AlonzoEraScript era, AlonzoScript era ~ Script era) =>
Script era -> ByteString
alonzoScriptPrefixTag

  getNativeScript :: Script BabbageEra -> Maybe (NativeScript BabbageEra)
getNativeScript = \case
    TimelockScript Timelock BabbageEra
ts -> forall a. a -> Maybe a
Just Timelock BabbageEra
ts
    Script BabbageEra
_ -> forall a. Maybe a
Nothing

  fromNativeScript :: NativeScript BabbageEra -> Script BabbageEra
fromNativeScript = forall era. Timelock era -> AlonzoScript era
TimelockScript

instance AlonzoEraScript BabbageEra where
  data PlutusScript BabbageEra
    = BabbagePlutusV1 !(Plutus 'PlutusV1)
    | BabbagePlutusV2 !(Plutus 'PlutusV2)
    deriving (PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
$c/= :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
== :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
$c== :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
Eq, Eq (PlutusScript BabbageEra)
PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
PlutusScript BabbageEra -> PlutusScript BabbageEra -> Ordering
PlutusScript BabbageEra
-> PlutusScript BabbageEra -> PlutusScript BabbageEra
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PlutusScript BabbageEra
-> PlutusScript BabbageEra -> PlutusScript BabbageEra
$cmin :: PlutusScript BabbageEra
-> PlutusScript BabbageEra -> PlutusScript BabbageEra
max :: PlutusScript BabbageEra
-> PlutusScript BabbageEra -> PlutusScript BabbageEra
$cmax :: PlutusScript BabbageEra
-> PlutusScript BabbageEra -> PlutusScript BabbageEra
>= :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
$c>= :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
> :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
$c> :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
<= :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
$c<= :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
< :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
$c< :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Bool
compare :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Ordering
$ccompare :: PlutusScript BabbageEra -> PlutusScript BabbageEra -> Ordering
Ord, Int -> PlutusScript BabbageEra -> ShowS
[PlutusScript BabbageEra] -> ShowS
PlutusScript BabbageEra -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlutusScript BabbageEra] -> ShowS
$cshowList :: [PlutusScript BabbageEra] -> ShowS
show :: PlutusScript BabbageEra -> String
$cshow :: PlutusScript BabbageEra -> String
showsPrec :: Int -> PlutusScript BabbageEra -> ShowS
$cshowsPrec :: Int -> PlutusScript BabbageEra -> ShowS
Show, forall x.
Rep (PlutusScript BabbageEra) x -> PlutusScript BabbageEra
forall x.
PlutusScript BabbageEra -> Rep (PlutusScript BabbageEra) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep (PlutusScript BabbageEra) x -> PlutusScript BabbageEra
$cfrom :: forall x.
PlutusScript BabbageEra -> Rep (PlutusScript BabbageEra) x
Generic)
  type PlutusPurpose f BabbageEra = AlonzoPlutusPurpose f BabbageEra

  eraMaxLanguage :: Language
eraMaxLanguage = Language
PlutusV2

  mkPlutusScript :: forall (l :: Language).
PlutusLanguage l =>
Plutus l -> Maybe (PlutusScript BabbageEra)
mkPlutusScript Plutus l
plutus =
    case forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> SLanguage l
plutusSLanguage Plutus l
plutus of
      SLanguage l
SPlutusV1 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Plutus 'PlutusV1 -> PlutusScript BabbageEra
BabbagePlutusV1 Plutus l
plutus
      SLanguage l
SPlutusV2 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Plutus 'PlutusV2 -> PlutusScript BabbageEra
BabbagePlutusV2 Plutus l
plutus
      SLanguage l
_ -> forall a. Maybe a
Nothing

  withPlutusScript :: forall a.
PlutusScript BabbageEra
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
withPlutusScript (BabbagePlutusV1 Plutus 'PlutusV1
plutus) forall (l :: Language). PlutusLanguage l => Plutus l -> a
f = forall (l :: Language). PlutusLanguage l => Plutus l -> a
f Plutus 'PlutusV1
plutus
  withPlutusScript (BabbagePlutusV2 Plutus 'PlutusV2
plutus) forall (l :: Language). PlutusLanguage l => Plutus l -> a
f = forall (l :: Language). PlutusLanguage l => Plutus l -> a
f Plutus 'PlutusV2
plutus

  hoistPlutusPurpose :: forall (g :: * -> * -> *) (f :: * -> * -> *).
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g BabbageEra -> PlutusPurpose f BabbageEra
hoistPlutusPurpose forall ix it. g ix it -> f ix it
f = \case
    AlonzoSpending g Word32 TxIn
x -> forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending forall a b. (a -> b) -> a -> b
$ forall ix it. g ix it -> f ix it
f g Word32 TxIn
x
    AlonzoMinting g Word32 PolicyID
x -> forall (f :: * -> * -> *) era.
f Word32 PolicyID -> AlonzoPlutusPurpose f era
AlonzoMinting forall a b. (a -> b) -> a -> b
$ forall ix it. g ix it -> f ix it
f g Word32 PolicyID
x
    AlonzoCertifying g Word32 (TxCert BabbageEra)
x -> forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> AlonzoPlutusPurpose f era
AlonzoCertifying forall a b. (a -> b) -> a -> b
$ forall ix it. g ix it -> f ix it
f g Word32 (TxCert BabbageEra)
x
    AlonzoRewarding g Word32 RewardAccount
x -> forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> AlonzoPlutusPurpose f era
AlonzoRewarding forall a b. (a -> b) -> a -> b
$ forall ix it. g ix it -> f ix it
f g Word32 RewardAccount
x

  mkSpendingPurpose :: forall (f :: * -> * -> *).
f Word32 TxIn -> PlutusPurpose f BabbageEra
mkSpendingPurpose = forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending

  toSpendingPurpose :: forall (f :: * -> * -> *).
PlutusPurpose f BabbageEra -> Maybe (f Word32 TxIn)
toSpendingPurpose (AlonzoSpending f Word32 TxIn
i) = forall a. a -> Maybe a
Just f Word32 TxIn
i
  toSpendingPurpose PlutusPurpose f BabbageEra
_ = forall a. Maybe a
Nothing

  mkMintingPurpose :: forall (f :: * -> * -> *).
f Word32 PolicyID -> PlutusPurpose f BabbageEra
mkMintingPurpose = forall (f :: * -> * -> *) era.
f Word32 PolicyID -> AlonzoPlutusPurpose f era
AlonzoMinting

  toMintingPurpose :: forall (f :: * -> * -> *).
PlutusPurpose f BabbageEra -> Maybe (f Word32 PolicyID)
toMintingPurpose (AlonzoMinting f Word32 PolicyID
i) = forall a. a -> Maybe a
Just f Word32 PolicyID
i
  toMintingPurpose PlutusPurpose f BabbageEra
_ = forall a. Maybe a
Nothing

  mkCertifyingPurpose :: forall (f :: * -> * -> *).
f Word32 (TxCert BabbageEra) -> PlutusPurpose f BabbageEra
mkCertifyingPurpose = forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> AlonzoPlutusPurpose f era
AlonzoCertifying

  toCertifyingPurpose :: forall (f :: * -> * -> *).
PlutusPurpose f BabbageEra -> Maybe (f Word32 (TxCert BabbageEra))
toCertifyingPurpose (AlonzoCertifying f Word32 (TxCert BabbageEra)
i) = forall a. a -> Maybe a
Just f Word32 (TxCert BabbageEra)
i
  toCertifyingPurpose PlutusPurpose f BabbageEra
_ = forall a. Maybe a
Nothing

  mkRewardingPurpose :: forall (f :: * -> * -> *).
f Word32 RewardAccount -> PlutusPurpose f BabbageEra
mkRewardingPurpose = forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> AlonzoPlutusPurpose f era
AlonzoRewarding

  toRewardingPurpose :: forall (f :: * -> * -> *).
PlutusPurpose f BabbageEra -> Maybe (f Word32 RewardAccount)
toRewardingPurpose (AlonzoRewarding f Word32 RewardAccount
i) = forall a. a -> Maybe a
Just f Word32 RewardAccount
i
  toRewardingPurpose PlutusPurpose f BabbageEra
_ = forall a. Maybe a
Nothing

  upgradePlutusPurposeAsIx :: AlonzoEraScript (PreviousEra BabbageEra) =>
PlutusPurpose AsIx (PreviousEra BabbageEra)
-> PlutusPurpose AsIx BabbageEra
upgradePlutusPurposeAsIx = \case
    AlonzoMinting (AsIx Word32
ix) -> forall (f :: * -> * -> *) era.
f Word32 PolicyID -> AlonzoPlutusPurpose f era
AlonzoMinting (forall ix it. ix -> AsIx ix it
AsIx Word32
ix)
    AlonzoSpending (AsIx Word32
ix) -> forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending (forall ix it. ix -> AsIx ix it
AsIx Word32
ix)
    AlonzoRewarding (AsIx Word32
ix) -> forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> AlonzoPlutusPurpose f era
AlonzoRewarding (forall ix it. ix -> AsIx ix it
AsIx Word32
ix)
    AlonzoCertifying (AsIx Word32
ix) -> forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> AlonzoPlutusPurpose f era
AlonzoCertifying (forall ix it. ix -> AsIx ix it
AsIx Word32
ix)

instance ShelleyEraScript BabbageEra where
  mkRequireSignature :: KeyHash 'Witness -> NativeScript BabbageEra
mkRequireSignature = forall era. Era era => KeyHash 'Witness -> Timelock era
mkRequireSignatureTimelock
  getRequireSignature :: NativeScript BabbageEra -> Maybe (KeyHash 'Witness)
getRequireSignature = forall {k} (era :: k). Timelock era -> Maybe (KeyHash 'Witness)
getRequireSignatureTimelock

  mkRequireAllOf :: StrictSeq (NativeScript BabbageEra) -> NativeScript BabbageEra
mkRequireAllOf = forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAllOfTimelock
  getRequireAllOf :: NativeScript BabbageEra
-> Maybe (StrictSeq (NativeScript BabbageEra))
getRequireAllOf = forall {k} (era :: k).
Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAllOfTimelock

  mkRequireAnyOf :: StrictSeq (NativeScript BabbageEra) -> NativeScript BabbageEra
mkRequireAnyOf = forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAnyOfTimelock
  getRequireAnyOf :: NativeScript BabbageEra
-> Maybe (StrictSeq (NativeScript BabbageEra))
getRequireAnyOf = forall {k} (era :: k).
Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAnyOfTimelock

  mkRequireMOf :: Int
-> StrictSeq (NativeScript BabbageEra) -> NativeScript BabbageEra
mkRequireMOf = forall era.
Era era =>
Int -> StrictSeq (Timelock era) -> Timelock era
mkRequireMOfTimelock
  getRequireMOf :: NativeScript BabbageEra
-> Maybe (Int, StrictSeq (NativeScript BabbageEra))
getRequireMOf = forall {k} (era :: k).
Timelock era -> Maybe (Int, StrictSeq (Timelock era))
getRequireMOfTimelock

instance AllegraEraScript BabbageEra where
  mkTimeStart :: SlotNo -> NativeScript BabbageEra
mkTimeStart = forall era. Era era => SlotNo -> Timelock era
mkTimeStartTimelock
  getTimeStart :: NativeScript BabbageEra -> Maybe SlotNo
getTimeStart = forall {k} (era :: k). Timelock era -> Maybe SlotNo
getTimeStartTimelock

  mkTimeExpire :: SlotNo -> NativeScript BabbageEra
mkTimeExpire = forall era. Era era => SlotNo -> Timelock era
mkTimeExpireTimelock
  getTimeExpire :: NativeScript BabbageEra -> Maybe SlotNo
getTimeExpire = forall {k} (era :: k). Timelock era -> Maybe SlotNo
getTimeExpireTimelock

instance NFData (PlutusScript BabbageEra) where
  rnf :: PlutusScript BabbageEra -> ()
rnf = forall a. a -> ()
rwhnf
instance NoThunks (PlutusScript BabbageEra)
instance SafeToHash (PlutusScript BabbageEra) where
  originalBytes :: PlutusScript BabbageEra -> ByteString
originalBytes PlutusScript BabbageEra
ps = forall era a.
AlonzoEraScript era =>
PlutusScript era
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
withPlutusScript PlutusScript BabbageEra
ps forall t. SafeToHash t => t -> ByteString
originalBytes

instance MemPack (PlutusScript BabbageEra) where
  packedByteCount :: PlutusScript BabbageEra -> Int
packedByteCount = \case
    BabbagePlutusV1 Plutus 'PlutusV1
script -> Int
packedTagByteCount forall a. Num a => a -> a -> a
+ forall a. MemPack a => a -> Int
packedByteCount Plutus 'PlutusV1
script
    BabbagePlutusV2 Plutus 'PlutusV2
script -> Int
packedTagByteCount forall a. Num a => a -> a -> a
+ forall a. MemPack a => a -> Int
packedByteCount Plutus 'PlutusV2
script
  packM :: forall s. PlutusScript BabbageEra -> Pack s ()
packM = \case
    BabbagePlutusV1 Plutus 'PlutusV1
script -> forall s. Tag -> Pack s ()
packTagM Tag
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a s. MemPack a => a -> Pack s ()
packM Plutus 'PlutusV1
script
    BabbagePlutusV2 Plutus 'PlutusV2
script -> forall s. Tag -> Pack s ()
packTagM Tag
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a s. MemPack a => a -> Pack s ()
packM Plutus 'PlutusV2
script
  {-# INLINE packM #-}
  unpackM :: forall b. Buffer b => Unpack b (PlutusScript BabbageEra)
unpackM =
    forall b. Buffer b => Unpack b Tag
unpackTagM forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Tag
0 -> Plutus 'PlutusV1 -> PlutusScript BabbageEra
BabbagePlutusV1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM
      Tag
1 -> Plutus 'PlutusV2 -> PlutusScript BabbageEra
BabbagePlutusV2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM
      Tag
n -> forall a (m :: * -> *) b. (MemPack a, MonadFail m) => Tag -> m b
unknownTagM @(PlutusScript BabbageEra) Tag
n
  {-# INLINE unpackM #-}