{-# 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,
  mkPlutusTxInfo,
) where

import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Plutus.Context (
  EraPlutusContext,
  EraPlutusTxInfo (..),
  LedgerTxInfo (..),
  PlutusTxInfo,
  SupportedLanguage (..),
  toPlutusTxInfoForPurpose,
 )
import Cardano.Ledger.Alonzo.Scripts (AsIx, PlutusPurpose, hoistPlutusPurpose, toAsPurpose)
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), Arbitrary (PlutusPurpose AsIx 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)
  protVer <- ProtVer version <$> arbitrary
  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
          }
  plutusPurpose <- arbitrary
  pure $ case supportedLanguage of
    SupportedLanguage SLanguage l
slang ->
      let
        txInfo :: PlutusTxInfo l
txInfo = SLanguage l
-> LedgerTxInfo era -> PlutusPurpose AsIx era -> PlutusTxInfo l
forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
SLanguage l
-> LedgerTxInfo era -> PlutusPurpose AsIx era -> PlutusTxInfo l
mkPlutusTxInfo SLanguage l
slang LedgerTxInfo era
lti PlutusPurpose AsIx era
plutusPurpose
       in
        TranslationInstance
          { tiProtVer :: ProtVer
tiProtVer = ProtVer
protVer
          , tiLanguage :: SupportedLanguage era
tiLanguage = SupportedLanguage era
supportedLanguage
          , tiUtxo :: UTxO era
tiUtxo = UTxO era
utxo
          , tiTx :: Tx TopTx era
tiTx = Tx TopTx era
tx
          , tiPlutusPurpose :: PlutusPurpose AsIx era
tiPlutusPurpose = PlutusPurpose AsIx era
plutusPurpose
          , tiResult :: VersionedTxInfo
tiResult = SLanguage l -> PlutusTxInfo l -> VersionedTxInfo
forall (l :: Language).
SLanguage l -> PlutusTxInfo l -> VersionedTxInfo
toVersionedTxInfo SLanguage l
slang PlutusTxInfo l
txInfo
          }

mkPlutusTxInfo ::
  (HasCallStack, EraPlutusTxInfo l era) =>
  SLanguage l -> LedgerTxInfo era -> PlutusPurpose AsIx era -> PlutusTxInfo l
mkPlutusTxInfo :: forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
SLanguage l
-> LedgerTxInfo era -> PlutusPurpose AsIx era -> PlutusTxInfo l
mkPlutusTxInfo SLanguage l
slang LedgerTxInfo era
lti PlutusPurpose AsIx era
plutusPurpose =
  (ContextError era -> PlutusTxInfo l)
-> (PlutusTxInfo l -> PlutusTxInfo l)
-> Either (ContextError era) (PlutusTxInfo l)
-> PlutusTxInfo l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> PlutusTxInfo l
forall a. HasCallStack => [Char] -> a
error ([Char] -> PlutusTxInfo l)
-> (ContextError era -> [Char])
-> ContextError era
-> PlutusTxInfo l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextError era -> [Char]
forall a. Show a => a -> [Char]
show) PlutusTxInfo l -> PlutusTxInfo l
forall a. a -> a
id (Either (ContextError era) (PlutusTxInfo l) -> PlutusTxInfo l)
-> Either (ContextError era) (PlutusTxInfo l) -> PlutusTxInfo l
forall a b. (a -> b) -> a -> b
$
    SLanguage l
-> LedgerTxInfo era
-> PlutusPurpose AsPurpose era
-> Either (ContextError era) (PlutusTxInfo l)
forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era
-> PlutusPurpose AsPurpose era
-> Either (ContextError era) (PlutusTxInfo l)
toPlutusTxInfoForPurpose SLanguage l
slang LedgerTxInfo era
lti ((forall ix it. AsIx ix it -> AsPurpose ix it)
-> PlutusPurpose AsIx era -> PlutusPurpose AsPurpose era
forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
forall (g :: * -> * -> *) (f :: * -> * -> *).
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose AsIx ix it -> AsPurpose ix it
forall ix it. AsIx ix it -> AsPurpose ix it
forall (f :: * -> * -> *) ix it. f ix it -> AsPurpose ix it
toAsPurpose PlutusPurpose AsIx era
plutusPurpose)

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