{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- TODO: Move to cardano-ledger-core:test-lib
module Test.Cardano.Ledger.TranslationTools (
  translateEraPartial,
  translateEraEncoding,
  translateEraEncCBOR,
)
where

import Cardano.Ledger.Binary (EncCBOR (..), toPlainEncoding)
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core
import Control.Monad
import Control.Monad.Except (runExcept)
import GHC.Stack
import Test.Cardano.Ledger.Binary.TreeDiff (CBORBytes (..), diffExprString)
import Test.Tasty.HUnit (Assertion, assertFailure)

translateEraPartial ::
  forall era f.
  (TranslateEra era f, Show (TranslationError era f), HasCallStack) =>
  TranslationContext era ->
  f (PreviousEra era) ->
  f era
translateEraPartial :: forall era (f :: * -> *).
(TranslateEra era f, Show (TranslationError era f),
 HasCallStack) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEraPartial TranslationContext era
tc f (PreviousEra era)
fe =
  case forall e a. Except e a -> Either e a
runExcept forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra @era TranslationContext era
tc f (PreviousEra era)
fe of
    Right f era
result -> f era
result
    Left TranslationError era f
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"TranslateEra failure: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show TranslationError era f
err

-- Tests that the serializing before translation or after translating does not change the
-- result
--
-- FIXME: This property only holds for annotated types. Replace this test with a better
-- one, since there is no requirement for two different eras to encode the type in the
-- same way. There is, however a requirement that the encoding from a previous era, must
-- be decodable by the current era.
translateEraEncoding ::
  forall era f.
  ( HasCallStack
  , TranslateEra era f
  , Show (TranslationError era f)
  ) =>
  TranslationContext era ->
  (f era -> Plain.Encoding) ->
  (f (PreviousEra era) -> Plain.Encoding) ->
  f (PreviousEra era) ->
  Assertion
translateEraEncoding :: forall era (f :: * -> *).
(HasCallStack, TranslateEra era f,
 Show (TranslationError era f)) =>
TranslationContext era
-> (f era -> Encoding)
-> (f (PreviousEra era) -> Encoding)
-> f (PreviousEra era)
-> Assertion
translateEraEncoding TranslationContext era
tc f era -> Encoding
encodeThisEra f (PreviousEra era) -> Encoding
encodePreviousEra f (PreviousEra era)
x =
  let previousEra :: ByteString
previousEra =
        forall a. ToCBOR a => a -> ByteString
Plain.serialize' (f (PreviousEra era) -> Encoding
encodePreviousEra f (PreviousEra era)
x)
      currentEra :: ByteString
currentEra =
        forall a. ToCBOR a => a -> ByteString
Plain.serialize' (f era -> Encoding
encodeThisEra forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
(TranslateEra era f, Show (TranslationError era f),
 HasCallStack) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEraPartial @era TranslationContext era
tc f (PreviousEra era)
x)
   in forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
previousEra forall a. Eq a => a -> a -> Bool
== ByteString
currentEra) forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$
          forall a. ToExpr a => a -> a -> [Char]
diffExprString (ByteString -> CBORBytes
CBORBytes ByteString
previousEra) (ByteString -> CBORBytes
CBORBytes ByteString
currentEra)

-- Tests that the serializing before translation or after translating
-- does not change the result
translateEraEncCBOR ::
  forall proxy era f.
  ( HasCallStack
  , TranslateEra era f
  , EncCBOR (f era)
  , EncCBOR (f (PreviousEra era))
  , Show (TranslationError era f)
  ) =>
  proxy era ->
  TranslationContext era ->
  f (PreviousEra era) ->
  Assertion
translateEraEncCBOR :: forall (proxy :: * -> *) era (f :: * -> *).
(HasCallStack, TranslateEra era f, EncCBOR (f era),
 EncCBOR (f (PreviousEra era)), Show (TranslationError era f)) =>
proxy era
-> TranslationContext era -> f (PreviousEra era) -> Assertion
translateEraEncCBOR proxy era
_ TranslationContext era
tc =
  forall era (f :: * -> *).
(HasCallStack, TranslateEra era f,
 Show (TranslationError era f)) =>
TranslationContext era
-> (f era -> Encoding)
-> (f (PreviousEra era) -> Encoding)
-> f (PreviousEra era)
-> Assertion
translateEraEncoding @era
    TranslationContext era
tc
    (forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era)
    (Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBOR a => a -> Encoding
encCBOR)