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

-- | Golden and round-trip testing of 'FromCBOR' and 'ToCBOR' instances
module Test.Cardano.Binary.Helpers.GoldenRoundTrip (
  goldenTestCBOR,
  goldenTestCBORExplicit,
  goldenTestExplicit,
  roundTripsCBORShow,
  roundTripsCBORBuildable,
  compareHexDump,
  deprecatedGoldenDecode,
)
where

import Test.Cardano.Prelude (
  decodeBase16,
  encodeWithIndex,
  trippingBuildable,
 )

import qualified Codec.CBOR.Decoding as D
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)
import Formatting.Buildable (Buildable (..))
import GHC.Stack (HasCallStack, withFrozenCallStack)
import Hedgehog (
  MonadTest,
  Property,
  eval,
  property,
  success,
  tripping,
  withTests,
  (===),
 )
import Hedgehog.Internal.Property (failWith)
import Hedgehog.Internal.Show (
  LineDiff,
  lineDiff,
  mkValue,
  renderLineDiff,
  showPretty,
 )

import Cardano.Binary (
  Decoder,
  DecoderError,
  Encoding,
  FromCBOR (..),
  ToCBOR (..),
  decodeFull,
  decodeFullDecoder,
  serialize,
 )
import Text.Show.Pretty (Value (..))

type HexDump = BSL.ByteString

type HexDumpDiff = [LineDiff]

renderHexDumpDiff :: HexDumpDiff -> [Char]
renderHexDumpDiff :: HexDumpDiff -> [Char]
renderHexDumpDiff = [[Char]] -> [Char]
Prelude.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LineDiff -> [Char]
renderLineDiff

-- | Diff two 'HexDump's by comparing lines pairwise
hexDumpDiff :: HexDump -> HexDump -> Maybe HexDumpDiff
hexDumpDiff :: ByteString -> ByteString -> Maybe HexDumpDiff
hexDumpDiff ByteString
x ByteString
y = do
  [Value]
xs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a. Show a => a -> Maybe Value
mkValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [ByteString]
BS.lines ByteString
x)
  [Value]
ys <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a. Show a => a -> Maybe Value
mkValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [ByteString]
BS.lines ByteString
y)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Value -> Value -> HexDumpDiff
lineDiff) forall a b. (a -> b) -> a -> b
$
      forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding
        ([Char] -> Value
String [Char]
"")
        ([Char] -> Value
String [Char]
"")
        [Value]
xs
        [Value]
ys

zipWithPadding :: a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding :: forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding a
a b
b (a
x : [a]
xs) (b
y : [b]
ys) = (a
x, b
y) forall a. a -> [a] -> [a]
: forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding a
a b
b [a]
xs [b]
ys
zipWithPadding a
a b
_ [] [b]
ys = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. a -> [a]
repeat a
a) [b]
ys
zipWithPadding a
_ b
b [a]
xs [] = forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs (forall a. a -> [a]
repeat b
b)

-- | A custom version of '(===)' for 'HexDump's to get prettier diffs
compareHexDump :: (MonadTest m, HasCallStack) => HexDump -> HexDump -> m ()
compareHexDump :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
compareHexDump ByteString
x ByteString
y = do
  Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
eval (ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
y)
  if Bool
ok then forall (m :: * -> *). MonadTest m => m ()
success else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
failHexDumpDiff ByteString
x ByteString
y

-- | Fail with a nice line diff of the two HexDumps
failHexDumpDiff :: (MonadTest m, HasCallStack) => HexDump -> HexDump -> m ()
failHexDumpDiff :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
failHexDumpDiff ByteString
x ByteString
y = case ByteString -> ByteString -> Maybe HexDumpDiff
hexDumpDiff ByteString
x ByteString
y of
  Maybe HexDumpDiff
Nothing ->
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
        [[Char]] -> [Char]
Prelude.unlines
          [[Char]
"━━━ Not Equal ━━━", forall a. Show a => a -> [Char]
showPretty ByteString
x, forall a. Show a => a -> [Char]
showPretty ByteString
y]
  Just HexDumpDiff
dif -> forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ HexDumpDiff -> [Char]
renderHexDumpDiff HexDumpDiff
dif

-- | Check that the 'encode' and 'decode' function of the 'Bi' instances work as
-- expected w.r.t. the give reference data, this is, given a value @x::a@, and
-- a file path @fp@:
--
-- - The encoded data should coincide with the contents of the @fp@.
-- - Decoding @fp@ should give as a result @x@
goldenTestCBOR ::
  forall a.
  (FromCBOR a, ToCBOR a, Eq a, Show a, HasCallStack) =>
  a ->
  FilePath ->
  Property
goldenTestCBOR :: forall a.
(FromCBOR a, ToCBOR a, Eq a, Show a, HasCallStack) =>
a -> [Char] -> Property
goldenTestCBOR =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
    forall a.
(Eq a, Show a, HasCallStack) =>
Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> [Char]
-> Property
goldenTestCBORExplicit (forall a. FromCBOR a => Proxy a -> Text
label forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a) forall a. ToCBOR a => a -> Encoding
toCBOR forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Variant of 'goldenTestBi' using custom encode and decode functions.
--
-- This is required for the encode/decode golden-tests for types that do no
-- have a 'Bi' instance.
goldenTestCBORExplicit ::
  forall a.
  (Eq a, Show a, HasCallStack) =>
  -- | Label for error reporting when decoding.
  Text ->
  (a -> Encoding) ->
  (forall s. Decoder s a) ->
  a ->
  FilePath ->
  Property
goldenTestCBORExplicit :: forall a.
(Eq a, Show a, HasCallStack) =>
Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> [Char]
-> Property
goldenTestCBORExplicit Text
eLabel a -> Encoding
enc forall s. Decoder s a
dec =
  forall a.
(Eq a, Show a, HasCallStack) =>
(a -> ByteString)
-> (ByteString -> Either DecoderError a) -> a -> [Char] -> Property
goldenTestExplicit (forall a. ToCBOR a => a -> ByteString
serialize forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding
enc) ByteString -> Either DecoderError a
fullDecoder
  where
    fullDecoder :: BSL.ByteString -> Either DecoderError a
    fullDecoder :: ByteString -> Either DecoderError a
fullDecoder = forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
eLabel forall s. Decoder s a
dec

goldenTestExplicit ::
  forall a.
  (Eq a, Show a, HasCallStack) =>
  (a -> BS.ByteString) ->
  (BS.ByteString -> Either DecoderError a) ->
  a ->
  FilePath ->
  Property
goldenTestExplicit :: forall a.
(Eq a, Show a, HasCallStack) =>
(a -> ByteString)
-> (ByteString -> Either DecoderError a) -> a -> [Char] -> Property
goldenTestExplicit a -> ByteString
encode ByteString -> Either DecoderError a
decode a
x [Char]
path = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  let bs' :: ByteString
bs' = ByteString -> ByteString
encodeWithIndex forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ a
x
  TestLimit -> Property -> Property
withTests TestLimit
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
    let target :: Maybe ByteString
target = ByteString -> Maybe ByteString
decodeBase16 ByteString
bs
    forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
compareHexDump ByteString
bs ByteString
bs'
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either DecoderError a
decode Maybe ByteString
target forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right a
x)

-- | Round trip test a value (any instance of 'FromCBOR', 'ToCBOR', and 'Show'
--   classes) by serializing it to a ByteString and back again and that also has
--   a 'Show' instance. If the 'a' type has both 'Show' and 'Buildable'
--   instances, it's best to use this version.
roundTripsCBORShow ::
  (FromCBOR a, ToCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
  a ->
  m ()
roundTripsCBORShow :: forall a (m :: * -> *).
(FromCBOR a, ToCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow a
x = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
tripping a
x forall a. ToCBOR a => a -> ByteString
serialize forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull

-- | Round trip (via ByteString) any instance of the 'FromCBOR' and 'ToCBOR'
--   class that also has a 'Buildable' instance.
roundTripsCBORBuildable ::
  (FromCBOR a, ToCBOR a, Eq a, MonadTest m, Buildable a, HasCallStack) =>
  a ->
  m ()
roundTripsCBORBuildable :: forall a (m :: * -> *).
(FromCBOR a, ToCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable a
a =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b (m :: * -> *).
(HasCallStack, Buildable (f a), Eq (f a), Show b, Applicative f,
 MonadTest m) =>
a -> (a -> b) -> (b -> f a) -> m ()
trippingBuildable a
a forall a. ToCBOR a => a -> ByteString
serialize forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull

deprecatedGoldenDecode ::
  HasCallStack => Text -> (forall s. D.Decoder s ()) -> FilePath -> Property
deprecatedGoldenDecode :: HasCallStack =>
Text -> (forall s. Decoder s ()) -> [Char] -> Property
deprecatedGoldenDecode Text
lbl forall s. Decoder s ()
decoder [Char]
path =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ TestLimit -> Property -> Property
withTests TestLimit
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
    Maybe ByteString
bs <- ByteString -> Maybe ByteString
decodeBase16 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ByteString
BS.readFile [Char]
path)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
lbl forall s. Decoder s ()
decoder) Maybe ByteString
bs forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right ())