{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.Translation.Golden (
  generateGoldenFile,
  assertTranslationResultsMatchGolden,
) where

import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, LedgerTxInfo (..), toPlutusTxInfo)
import Cardano.Ledger.Alonzo.Scripts (AlonzoEraScript)
import Cardano.Ledger.Binary.Encoding (serialize)
import Cardano.Ledger.Core
import Control.Exception (throwIO)
import qualified Data.ByteString.Lazy as BSL
import Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen (
  TranslatableGen (..),
  TxInfoLanguage (..),
  epochInfo,
  systemStart,
  toVersionedTxInfo,
  translationInstances,
 )
import Test.Cardano.Ledger.Alonzo.Translation.TranslationInstance (
  TranslationInstance (..),
  deserializeTranslationInstances,
 )
import Test.Cardano.Ledger.Common
import Test.HUnit (Assertion, assertEqual)

-- | Generates arguments for `ExtendedUTxO.txInfo`, applies them to it
-- and serializes both arguments and result to golden/translations.cbor file
generateGoldenFile ::
  forall era.
  ( Show (ContextError era)
  , AlonzoEraScript era
  , TranslatableGen era
  ) =>
  FilePath ->
  IO ()
generateGoldenFile :: forall era.
(Show (ContextError era), AlonzoEraScript era,
 TranslatableGen era) =>
FilePath -> IO ()
generateGoldenFile FilePath
file = do
  FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Generating golden file for TxInfo: " forall a. Semigroup a => a -> a -> a
<> FilePath
file
  let instances :: [TranslationInstance era]
instances = forall era.
(AlonzoEraScript era, TranslatableGen era,
 Show (ContextError era)) =>
Int -> Int -> [TranslationInstance era]
translationInstances @era Int
100 Int
100000 -- 100 instances with an arbitrary seed
  let cbor :: ByteString
cbor = forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerHigh @era) [TranslationInstance era]
instances
  FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
file ByteString
cbor

assertTranslationResultsMatchGolden ::
  forall era.
  ( TranslatableGen era
  , Show (ContextError era)
  , HasCallStack
  ) =>
  IO FilePath ->
  Assertion
assertTranslationResultsMatchGolden :: forall era.
(TranslatableGen era, Show (ContextError era), HasCallStack) =>
IO FilePath -> IO ()
assertTranslationResultsMatchGolden IO FilePath
file = do
  ByteString
bs <- IO FilePath
file forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO ByteString
BSL.readFile
  [TranslationInstance era]
instances <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
(Era era, DecCBOR (PParams era), DecCBOR (UTxO era),
 DecCBOR (Annotator (Tx era))) =>
ByteString -> Either DecoderError [TranslationInstance era]
deserializeTranslationInstances @era ByteString
bs)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall era.
(TranslatableGen era, Show (ContextError era), HasCallStack) =>
TranslationInstance era -> IO ()
assertTranslationComparison [TranslationInstance era]
instances

assertTranslationComparison ::
  forall era.
  ( TranslatableGen era
  , Show (ContextError era)
  , HasCallStack
  ) =>
  TranslationInstance era ->
  Assertion
assertTranslationComparison :: forall era.
(TranslatableGen era, Show (ContextError era), HasCallStack) =>
TranslationInstance era -> IO ()
assertTranslationComparison (TranslationInstance ProtVer
protVer Language
lang UTxO era
utxo Tx era
tx VersionedTxInfo
expected) =
  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
e -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show ContextError era
e
        Right PlutusTxInfo l
actual -> forall a.
(HasCallStack, Eq a, Show a) =>
FilePath -> a -> a -> IO ()
assertEqual FilePath
errorMessage VersionedTxInfo
expected forall a b. (a -> b) -> a -> b
$ forall (l :: Language).
SLanguage l -> PlutusTxInfo l -> VersionedTxInfo
toVersionedTxInfo SLanguage l
slang PlutusTxInfo l
actual
  where
    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
        }
    errorMessage :: FilePath
errorMessage =
      [FilePath] -> FilePath
unlines
        [ FilePath
"Unexpected txinfo with arguments: "
        , FilePath
" ProtVer: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show ProtVer
protVer
        , FilePath
" language: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Language
lang
        , FilePath
" utxo: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show UTxO era
utxo
        , FilePath
" tx: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Tx era
tx
        ]