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

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

import Cardano.Ledger.Alonzo (Alonzo)
import Cardano.Ledger.Alonzo.Plutus.Context (
  ContextError,
  EraPlutusTxInfo,
  LedgerTxInfo (..),
  PlutusTxInfo,
  toPlutusTxInfo,
 )
import Cardano.Ledger.Alonzo.Scripts (AlonzoEraScript (eraMaxLanguage))
import Cardano.Ledger.Alonzo.TxWits (Redeemers)
import Cardano.Ledger.Core as Core
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
import Cardano.Ledger.UTxO (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 GHC.Stack
import Lens.Micro ((^.))
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
import Test.Cardano.Ledger.Alonzo.Translation.TranslationInstance (
  TranslationInstance (..),
  VersionedTxInfo (..),
 )
import Test.QuickCheck (Gen, arbitrary, elements, vectorOf)
import Test.QuickCheck.Gen (Gen (MkGen))
import Test.QuickCheck.Random (mkQCGen)

data TxInfoLanguage era where
  TxInfoLanguage :: EraPlutusTxInfo l era => SLanguage l -> TxInfoLanguage era

class EraTx era => TranslatableGen era where
  tgRedeemers :: Gen (Redeemers era)
  tgTx :: Language -> Gen (Core.Tx era)
  tgUtxo :: Language -> Core.Tx era -> Gen (UTxO era)
  mkTxInfoLanguage :: HasCallStack => Language -> TxInfoLanguage era

instance TranslatableGen Alonzo where
  tgRedeemers :: Gen (Redeemers Alonzo)
tgRedeemers = forall a. Arbitrary a => Gen a
arbitrary
  tgTx :: Language -> Gen (Tx Alonzo)
tgTx Language
_ = forall a. Arbitrary a => Gen a
arbitrary :: Gen (Tx Alonzo)
  tgUtxo :: Language -> Tx Alonzo -> Gen (UTxO Alonzo)
tgUtxo Language
_ Tx Alonzo
tx = do
    let ins :: Set (TxIn (EraCrypto Alonzo))
ins = Tx Alonzo
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL
    [AlonzoTxOut Alonzo]
outs <- forall a. Int -> Gen a -> Gen [a]
vectorOf (forall (t :: * -> *) a. Foldable t => t a -> Int
length Set (TxIn (EraCrypto Alonzo))
ins) (forall a. Arbitrary a => Gen a
arbitrary :: Gen (TxOut Alonzo))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set (TxIn (EraCrypto Alonzo))
ins forall a b. [a] -> [b] -> [(a, b)]
`zip` [AlonzoTxOut Alonzo]
outs)
  mkTxInfoLanguage :: HasCallStack => Language -> TxInfoLanguage Alonzo
mkTxInfoLanguage Language
PlutusV1 = forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> TxInfoLanguage era
TxInfoLanguage SLanguage 'PlutusV1
SPlutusV1
  mkTxInfoLanguage Language
lang =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Language " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Language
lang forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported in " forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @Alonzo

translationInstances ::
  forall era.
  ( AlonzoEraScript era
  , TranslatableGen era
  , Show (ContextError era)
  ) =>
  Int ->
  Int ->
  [TranslationInstance era]
translationInstances :: forall era.
(AlonzoEraScript era, TranslatableGen era,
 Show (ContextError era)) =>
Int -> Int -> [TranslationInstance era]
translationInstances Int
size Int
seed =
  forall a. Int -> Gen a -> a
generateWithSeed Int
seed forall a b. (a -> b) -> a -> b
$ forall a. Int -> Gen a -> Gen [a]
vectorOf Int
size forall era.
(AlonzoEraScript era, TranslatableGen era,
 Show (ContextError era)) =>
Gen (TranslationInstance era)
genTranslationInstance

generateWithSeed :: Int -> Gen a -> a
generateWithSeed :: forall a. Int -> Gen a -> a
generateWithSeed Int
seed (MkGen QCGen -> Int -> a
g) = QCGen -> Int -> a
g (Int -> QCGen
mkQCGen Int
seed) Int
30

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
    SLanguage l
SPlutusV2 -> TxInfo -> VersionedTxInfo
TxInfoPV2 PlutusTxInfo l
txInfo
    SLanguage l
SPlutusV3 -> TxInfo -> VersionedTxInfo
TxInfoPV3 PlutusTxInfo l
txInfo

genTranslationInstance ::
  forall era.
  ( AlonzoEraScript era
  , TranslatableGen era
  , Show (ContextError era)
  ) =>
  Gen (TranslationInstance era)
genTranslationInstance :: forall era.
(AlonzoEraScript era, TranslatableGen era,
 Show (ContextError era)) =>
Gen (TranslationInstance era)
genTranslationInstance = do
  ProtVer
protVer <- forall a. Arbitrary a => Gen a
arbitrary
  Language
lang <- forall a. HasCallStack => [a] -> Gen a
elements [forall a. Bounded a => a
minBound .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era]
  Tx era
tx <- forall era. TranslatableGen era => Language -> Gen (Tx era)
tgTx @era Language
lang
  UTxO era
utxo <- forall era.
TranslatableGen era =>
Language -> Tx era -> Gen (UTxO era)
tgUtxo Language
lang Tx era
tx
  let lti :: LedgerTxInfo era
lti =
        LedgerTxInfo
          { ltiProtVer :: ProtVer
ltiProtVer = ProtVer
protVer
          , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = 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 forall era.
(TranslatableGen era, HasCallStack) =>
Language -> TxInfoLanguage era
mkTxInfoLanguage @era Language
lang of
    TxInfoLanguage SLanguage l
slang -> do
      case forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
toPlutusTxInfo SLanguage l
slang LedgerTxInfo era
lti of
        Left ContextError era
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ContextError era
err
        Right PlutusTxInfo l
txInfo -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ProtVer
-> Language
-> UTxO era
-> Tx era
-> VersionedTxInfo
-> TranslationInstance era
TranslationInstance ProtVer
protVer Language
lang UTxO era
utxo Tx era
tx forall a b. (a -> b) -> a -> b
$ 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 = 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 forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
1684445839000 -- 18/05/2023