{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen (
  TranslatableGen (..),
  translationInstances,
  epochInfo,
  toVersionedTxInfo,
  systemStart,
) where

import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Plutus.Context (
  EraPlutusContext,
  LedgerTxInfo (..),
  PlutusTxInfo,
  SupportedLanguage (..),
  toPlutusTxInfo,
 )
import Cardano.Ledger.Alonzo.TxWits (Redeemers)
import Cardano.Ledger.Core as Core
import Cardano.Ledger.Plutus.Language (SLanguage (..))
import Cardano.Ledger.State (UTxO (..))
import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo)
import Cardano.Slotting.Slot (EpochSize (..))
import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Lens.Micro ((^.))
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
import Test.Cardano.Ledger.Alonzo.Translation.TranslationInstance (
  TranslationInstance (..),
  VersionedTxInfo (..),
 )
import Test.Cardano.Ledger.Common

class (EraTx era, EraPlutusContext era, Arbitrary (Script era)) => TranslatableGen era where
  tgRedeemers :: Gen (Redeemers era)
  tgTx :: SupportedLanguage era -> Gen (Core.Tx era)
  tgUtxo :: SupportedLanguage era -> Core.Tx era -> Gen (UTxO era)

instance TranslatableGen AlonzoEra where
  tgRedeemers :: Gen (Redeemers AlonzoEra)
tgRedeemers = Gen (Redeemers AlonzoEra)
forall a. Arbitrary a => Gen a
arbitrary
  tgTx :: SupportedLanguage AlonzoEra -> Gen (Tx AlonzoEra)
tgTx SupportedLanguage AlonzoEra
_ = Gen (Tx AlonzoEra)
Gen (AlonzoTx AlonzoEra)
forall a. Arbitrary a => Gen a
arbitrary :: Gen (Tx AlonzoEra)
  tgUtxo :: SupportedLanguage AlonzoEra -> Tx AlonzoEra -> Gen (UTxO AlonzoEra)
tgUtxo SupportedLanguage AlonzoEra
_ Tx AlonzoEra
tx = do
    let ins :: Set TxIn
ins = Tx AlonzoEra
AlonzoTx AlonzoEra
tx AlonzoTx AlonzoEra
-> Getting
     (TxBody AlonzoEra) (AlonzoTx AlonzoEra) (TxBody AlonzoEra)
-> TxBody AlonzoEra
forall s a. s -> Getting a s a -> a
^. (TxBody AlonzoEra -> Const (TxBody AlonzoEra) (TxBody AlonzoEra))
-> Tx AlonzoEra -> Const (TxBody AlonzoEra) (Tx AlonzoEra)
Getting (TxBody AlonzoEra) (AlonzoTx AlonzoEra) (TxBody AlonzoEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx AlonzoEra) (TxBody AlonzoEra)
bodyTxL TxBody AlonzoEra
-> Getting (Set TxIn) (TxBody AlonzoEra) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody AlonzoEra) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody AlonzoEra) (Set TxIn)
inputsTxBodyL
    [AlonzoTxOut AlonzoEra]
outs <- Int -> Gen (AlonzoTxOut AlonzoEra) -> Gen [AlonzoTxOut AlonzoEra]
forall a. Int -> Gen a -> Gen [a]
vectorOf (Set TxIn -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set TxIn
ins) (Gen (TxOut AlonzoEra)
Gen (AlonzoTxOut AlonzoEra)
forall a. Arbitrary a => Gen a
arbitrary :: Gen (TxOut AlonzoEra))
    UTxO AlonzoEra -> Gen (UTxO AlonzoEra)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO AlonzoEra -> Gen (UTxO AlonzoEra))
-> UTxO AlonzoEra -> Gen (UTxO AlonzoEra)
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut AlonzoEra) -> UTxO AlonzoEra
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO ([(TxIn, TxOut AlonzoEra)] -> Map TxIn (TxOut AlonzoEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut AlonzoEra)] -> Map TxIn (TxOut AlonzoEra))
-> [(TxIn, TxOut AlonzoEra)] -> Map TxIn (TxOut AlonzoEra)
forall a b. (a -> b) -> a -> b
$ Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList Set TxIn
ins [TxIn]
-> [AlonzoTxOut AlonzoEra] -> [(TxIn, AlonzoTxOut AlonzoEra)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [AlonzoTxOut AlonzoEra]
outs)

translationInstances ::
  TranslatableGen era =>
  Int ->
  Int ->
  [TranslationInstance era]
translationInstances :: forall era.
TranslatableGen era =>
Int -> Int -> [TranslationInstance era]
translationInstances Int
size Int
seed =
  Int
-> Int
-> Gen [TranslationInstance era]
-> [TranslationInstance era]
forall a. Int -> Int -> Gen a -> a
runGen Int
seed Int
30 (Gen [TranslationInstance era] -> [TranslationInstance era])
-> Gen [TranslationInstance era] -> [TranslationInstance era]
forall a b. (a -> b) -> a -> b
$ Int
-> Gen (TranslationInstance era) -> Gen [TranslationInstance era]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
size Gen (TranslationInstance era)
forall era. TranslatableGen era => Gen (TranslationInstance era)
genTranslationInstance

toVersionedTxInfo :: SLanguage l -> PlutusTxInfo l -> VersionedTxInfo
toVersionedTxInfo :: forall (l :: Language).
SLanguage l -> PlutusTxInfo l -> VersionedTxInfo
toVersionedTxInfo SLanguage l
slang PlutusTxInfo l
txInfo =
  case SLanguage l
slang of
    SLanguage l
SPlutusV1 -> TxInfo -> VersionedTxInfo
TxInfoPV1 PlutusTxInfo l
TxInfo
txInfo
    SLanguage l
SPlutusV2 -> TxInfo -> VersionedTxInfo
TxInfoPV2 PlutusTxInfo l
TxInfo
txInfo
    SLanguage l
SPlutusV3 -> TxInfo -> VersionedTxInfo
TxInfoPV3 PlutusTxInfo l
TxInfo
txInfo

genTranslationInstance ::
  forall era.
  TranslatableGen era =>
  Gen (TranslationInstance era)
genTranslationInstance :: forall era. TranslatableGen era => Gen (TranslationInstance era)
genTranslationInstance = do
  ProtVer
protVer <- Gen ProtVer
forall a. Arbitrary a => Gen a
arbitrary
  SupportedLanguage era
supportedLanguage :: SupportedLanguage era <- Gen (SupportedLanguage era)
forall a. Arbitrary a => Gen a
arbitrary
  Tx era
tx <- SupportedLanguage era -> Gen (Tx era)
forall era.
TranslatableGen era =>
SupportedLanguage era -> Gen (Tx era)
tgTx SupportedLanguage era
supportedLanguage
  UTxO era
utxo <- SupportedLanguage era -> Tx era -> Gen (UTxO era)
forall era.
TranslatableGen era =>
SupportedLanguage era -> Tx era -> Gen (UTxO era)
tgUtxo SupportedLanguage era
supportedLanguage Tx era
tx
  let lti :: LedgerTxInfo era
lti =
        LedgerTxInfo
          { ltiProtVer :: ProtVer
ltiProtVer = ProtVer
protVer
          , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = EpochInfo (Either Text)
forall a. EpochInfo (Either a)
epochInfo
          , ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
systemStart
          , ltiUTxO :: UTxO era
ltiUTxO = UTxO era
utxo
          , ltiTx :: Tx era
ltiTx = Tx era
tx
          }
  case SupportedLanguage era
supportedLanguage of
    SupportedLanguage SLanguage l
slang -> do
      case SLanguage l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
forall (proxy :: Language -> *).
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
toPlutusTxInfo SLanguage l
slang LedgerTxInfo era
lti of
        Left ContextError era
err -> [Char] -> Gen (TranslationInstance era)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen (TranslationInstance era))
-> [Char] -> Gen (TranslationInstance era)
forall a b. (a -> b) -> a -> b
$ ContextError era -> [Char]
forall a. Show a => a -> [Char]
show ContextError era
err
        Right PlutusTxInfo l
txInfo ->
          TranslationInstance era -> Gen (TranslationInstance era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TranslationInstance era -> Gen (TranslationInstance era))
-> TranslationInstance era -> Gen (TranslationInstance era)
forall a b. (a -> b) -> a -> b
$ ProtVer
-> SupportedLanguage era
-> UTxO era
-> Tx era
-> VersionedTxInfo
-> TranslationInstance era
forall era.
ProtVer
-> SupportedLanguage era
-> UTxO era
-> Tx era
-> VersionedTxInfo
-> TranslationInstance era
TranslationInstance ProtVer
protVer SupportedLanguage era
supportedLanguage UTxO era
utxo Tx era
tx (VersionedTxInfo -> TranslationInstance era)
-> VersionedTxInfo -> TranslationInstance era
forall a b. (a -> b) -> a -> b
$ SLanguage l -> PlutusTxInfo l -> VersionedTxInfo
forall (l :: Language).
SLanguage l -> PlutusTxInfo l -> VersionedTxInfo
toVersionedTxInfo SLanguage l
slang PlutusTxInfo l
txInfo

epochInfo :: EpochInfo (Either a)
epochInfo :: forall a. EpochInfo (Either a)
epochInfo = EpochSize -> SlotLength -> EpochInfo (Either a)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo (Word64 -> EpochSize
EpochSize Word64
100) (POSIXTime -> SlotLength
mkSlotLength POSIXTime
1)

systemStart :: SystemStart
systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
1684445839000 -- 18/05/2023