{-# 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 Except (TranslationError era f) (f era)
-> Either (TranslationError era f) (f era)
forall e a. Except e a -> Either e a
runExcept (Except (TranslationError era f) (f era)
 -> Either (TranslationError era f) (f era))
-> Except (TranslationError era f) (f era)
-> Either (TranslationError era f) (f era)
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 -> [Char] -> f era
forall a. HasCallStack => [Char] -> a
error ([Char] -> f era) -> [Char] -> f era
forall a b. (a -> b) -> a -> b
$ [Char]
"TranslateEra failure: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TranslationError era f -> [Char]
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 =
        Encoding -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize' (f (PreviousEra era) -> Encoding
encodePreviousEra f (PreviousEra era)
x)
      currentEra :: ByteString
currentEra =
        Encoding -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize' (f era -> Encoding
encodeThisEra (f era -> Encoding) -> f era -> Encoding
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 Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
previousEra ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
currentEra) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
        [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$
          CBORBytes -> CBORBytes -> [Char]
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)) (Encoding -> Encoding)
-> (f (PreviousEra era) -> Encoding)
-> f (PreviousEra era)
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (PreviousEra era) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR)