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

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

import Cardano.Ledger.Alonzo.Plutus.Context (
  LedgerTxInfo (..),
  SupportedLanguage (..),
  toPlutusTxInfo,
 )
import Cardano.Ledger.Binary
import Cardano.Ledger.Core
import Control.Exception (throwIO)
import qualified Data.ByteString.Lazy as BSL
import Test.Cardano.Ledger.Alonzo.Binary.Annotator ()
import Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen (
  TranslatableGen (..),
  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.
  TranslatableGen era =>
  FilePath ->
  IO ()
generateGoldenFile :: forall era. TranslatableGen era => FilePath -> IO ()
generateGoldenFile FilePath
file = do
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Generating golden file for TxInfo: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file
  let instances :: [TranslationInstance era]
instances = forall era.
TranslatableGen era =>
Int -> Int -> [TranslationInstance era]
translationInstances @era Int
100 Int
100000 -- 100 instances with an arbitrary seed
  let cbor :: ByteString
cbor = Version -> [TranslationInstance era] -> ByteString
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
  , DecCBOR (Tx TopTx era)
  , HasCallStack
  ) =>
  IO FilePath ->
  Assertion
assertTranslationResultsMatchGolden :: forall era.
(TranslatableGen era, DecCBOR (Tx TopTx era), HasCallStack) =>
IO FilePath -> IO ()
assertTranslationResultsMatchGolden IO FilePath
file = do
  bs <- IO FilePath
file IO FilePath -> (FilePath -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO ByteString
BSL.readFile
  instances <- either throwIO pure (deserializeTranslationInstances @era bs)
  mapM_ assertTranslationComparison instances

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