{-# 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.BaseTypes (ProtVer (ProtVer))
import Cardano.Ledger.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 (Tx TopTx era)
  tgUtxo :: SupportedLanguage era -> Tx TopTx 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 TopTx AlonzoEra)
tgTx SupportedLanguage AlonzoEra
_ = Gen (Tx TopTx AlonzoEra)
forall a. Arbitrary a => Gen a
arbitrary
  tgUtxo :: SupportedLanguage AlonzoEra
-> Tx TopTx AlonzoEra -> Gen (UTxO AlonzoEra)
tgUtxo SupportedLanguage AlonzoEra
_ Tx TopTx AlonzoEra
tx = do
    let ins :: Set TxIn
ins = Tx TopTx AlonzoEra
tx Tx TopTx AlonzoEra
-> Getting
     (TxBody TopTx AlonzoEra)
     (Tx TopTx AlonzoEra)
     (TxBody TopTx AlonzoEra)
-> TxBody TopTx AlonzoEra
forall s a. s -> Getting a s a -> a
^. Getting
  (TxBody TopTx AlonzoEra)
  (Tx TopTx AlonzoEra)
  (TxBody TopTx AlonzoEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l AlonzoEra) (TxBody l AlonzoEra)
bodyTxL TxBody TopTx AlonzoEra
-> Getting (Set TxIn) (TxBody TopTx AlonzoEra) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx AlonzoEra) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l AlonzoEra) (Set TxIn)
inputsTxBodyL
    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))
    pure $ UTxO (Map.fromList $ Set.toList ins `zip` 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
    SLanguage l
SPlutusV4 -> TxInfo -> VersionedTxInfo
TxInfoPV4 PlutusTxInfo l
TxInfo
txInfo

genTranslationInstance ::
  forall era.
  TranslatableGen era =>
  Gen (TranslationInstance era)
genTranslationInstance :: forall era. TranslatableGen era => Gen (TranslationInstance era)
genTranslationInstance = do
  version <- (Version, Version) -> Gen Version
forall a. Random a => (a, a) -> Gen a
choose (forall era. Era era => Version
eraProtVerLow @era, forall era. Era era => Version
eraProtVerHigh @era)
  let protVer = Version -> Natural -> ProtVer
ProtVer Version
version Natural
0
  supportedLanguage :: SupportedLanguage era <- arbitrary
  tx <- tgTx supportedLanguage
  utxo <- tgUtxo supportedLanguage tx
  let 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 TopTx era
ltiTx = Tx TopTx era
tx
          }
  case 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 TopTx era
-> VersionedTxInfo
-> TranslationInstance era
forall era.
ProtVer
-> SupportedLanguage era
-> UTxO era
-> Tx TopTx era
-> VersionedTxInfo
-> TranslationInstance era
TranslationInstance ProtVer
protVer SupportedLanguage era
supportedLanguage UTxO era
utxo Tx TopTx 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