{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Binary.TreeDiff (
  ToExpr (..),
  CBORBytes (..),
  HexBytes (..),
  showExpr,
  ansiExpr,
  ansiExprString,
  diffExpr,
  diffExprString,
  diffExprCompact,
  diffExprCompactString,
  ansiDocToString,
  hexByteStringExpr,
  showHexBytesGrouped,
  assertColorFailure,
  expectExprEqual,
  expectExprEqualWithMessage,
  assertExprEqualWithMessage,
  callStackToLocation,
  srcLocToLocation,
  Expr (App, Rec, Lst),
  defaultExprViaShow,
  trimExprViaShow,
  tableDoc,
  Pretty (..),
  Doc,
  AnsiStyle,
  ansiWlPretty,
  ppEditExpr,
  ediff,
)
where

import qualified Cardano.Binary as Plain
import qualified Cardano.Crypto.DSIGN as DSIGN
import qualified Cardano.Crypto.Hash as Hash
import Cardano.Crypto.Hash.Class ()
import Cardano.Ledger.Binary
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import Data.Bifunctor (bimap)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (toList)
import Data.IP (IPv4, IPv6)
import Data.Maybe.Strict (StrictMaybe)
import Data.Sequence.Strict (StrictSeq)
import Data.TreeDiff
import GHC.Stack (HasCallStack)
import Prettyprinter (Doc)
import qualified Prettyprinter as Pretty
import Prettyprinter.Render.Terminal (AnsiStyle)
import Test.Cardano.Slotting.TreeDiff ()
import Test.Hspec (Expectation)
import Test.ImpSpec (ansiDocToString)
import Test.ImpSpec.Expectations (assertColorFailure, callStackToLocation, srcLocToLocation)
import Test.Tasty.HUnit (Assertion, assertFailure)

-- =====================================================
-- Cardano functions that deal with TreeDiff and ToExpr

trimExprViaShow :: Show a => Int -> a -> Expr
trimExprViaShow :: forall a. Show a => Int -> a -> Expr
trimExprViaShow Int
_n a
x = forall a. Show a => a -> Expr
defaultExprViaShow a
x -- App (take n (drop 1 (show x)) ++ "..") []

tableDoc :: Maybe (Doc AnsiStyle) -> [(String, Doc AnsiStyle)] -> Doc AnsiStyle
tableDoc :: Maybe (Doc AnsiStyle) -> [(String, Doc AnsiStyle)] -> Doc AnsiStyle
tableDoc Maybe (Doc AnsiStyle)
mTitle [(String, Doc AnsiStyle)]
rows =
  let w :: Int
w = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Ord a => a -> a -> a
max forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Int
0 [(String, Doc AnsiStyle)]
rows
      t :: Doc AnsiStyle
t = case Maybe (Doc AnsiStyle)
mTitle of
        Just Doc AnsiStyle
title -> forall ann. [Doc ann] -> Doc ann
Pretty.hsep [Doc AnsiStyle
"-----", Doc AnsiStyle
title, Doc AnsiStyle
"-----"] forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
Pretty.line
        Maybe (Doc AnsiStyle)
Nothing -> forall a. Monoid a => a
mempty
   in Doc AnsiStyle
t forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
Pretty.vsep [forall ann. Int -> Doc ann -> Doc ann
Pretty.fill (Int
w forall a. Num a => a -> a -> a
+ Int
1) (forall a ann. Pretty a => a -> Doc ann
Pretty.pretty String
l) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
r | (String
l, Doc AnsiStyle
r) <- [(String, Doc AnsiStyle)]
rows]

-- ===========================================================
-- Orphan instances from external imports

instance ToExpr IPv4

instance ToExpr IPv6

instance ToExpr (Hash.Hash c index) where
  toExpr :: Hash c index -> Expr
toExpr = forall a. Show a => Int -> a -> Expr
trimExprViaShow Int
10

instance DSIGN.DSIGNAlgorithm c => ToExpr (DSIGN.SignedDSIGN c index) where
  toExpr :: SignedDSIGN c index -> Expr
toExpr = forall a. Show a => Int -> a -> Expr
trimExprViaShow Int
10

instance ToExpr a => ToExpr (StrictSeq a) where
  toExpr :: StrictSeq a -> Expr
toExpr StrictSeq a
x = String -> [Expr] -> Expr
App String
"StrictSeqFromList" [forall a. ToExpr a => [a] -> Expr
listToExpr (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq a
x)]

instance ToExpr a => ToExpr (StrictMaybe a)

instance ToExpr Version where
  toExpr :: Version -> Expr
toExpr Version
v = String -> [Expr] -> Expr
App String
"Version" [forall a. ToExpr a => a -> Expr
toExpr (Version -> Word64
getVersion64 Version
v)]

instance ToExpr a => ToExpr (Sized a)

--------------------------------------------------------------------------------
--  Diffing and pretty showing CBOR
--------------------------------------------------------------------------------

showExpr :: ToExpr a => a -> String
showExpr :: forall a. ToExpr a => a -> String
showExpr = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Doc
prettyExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpr a => a -> Expr
toExpr

ansiExpr :: ToExpr a => a -> Doc AnsiStyle
ansiExpr :: forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr = Expr -> Doc AnsiStyle
ansiWlExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpr a => a -> Expr
toExpr

ansiExprString :: ToExpr a => a -> String
ansiExprString :: forall a. ToExpr a => a -> String
ansiExprString = Doc AnsiStyle -> String
ansiDocToString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr

diffExpr :: ToExpr a => a -> a -> Doc AnsiStyle
diffExpr :: forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr a
x a
y = Edit EditExpr -> Doc AnsiStyle
ansiWlEditExpr (forall a. ToExpr a => a -> a -> Edit EditExpr
ediff a
x a
y)

diffExprString :: ToExpr a => a -> a -> String
diffExprString :: forall a. ToExpr a => a -> a -> String
diffExprString a
x a
y = Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr a
x a
y

diffExprCompact :: ToExpr a => a -> a -> Doc AnsiStyle
diffExprCompact :: forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExprCompact a
x a
y = Edit EditExpr -> Doc AnsiStyle
ansiWlEditExprCompact (forall a. ToExpr a => a -> a -> Edit EditExpr
ediff a
x a
y)

diffExprCompactString :: ToExpr a => a -> a -> String
diffExprCompactString :: forall a. ToExpr a => a -> a -> String
diffExprCompactString a
x a
y = Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExprCompact a
x a
y

-- | Wraps regular ByteString, but shows and diffs it as hex
newtype HexBytes = HexBytes {HexBytes -> ByteString
unHexBytes :: BS.ByteString}
  deriving (HexBytes -> HexBytes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HexBytes -> HexBytes -> Bool
$c/= :: HexBytes -> HexBytes -> Bool
== :: HexBytes -> HexBytes -> Bool
$c== :: HexBytes -> HexBytes -> Bool
Eq)

instance Show HexBytes where
  show :: HexBytes -> String
show = forall a. ToExpr a => a -> String
showExpr

instance ToExpr HexBytes where
  toExpr :: HexBytes -> Expr
toExpr = String -> [Expr] -> Expr
App String
"HexBytes" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Expr]
hexByteStringExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexBytes -> ByteString
unHexBytes

newtype CBORBytes = CBORBytes {CBORBytes -> ByteString
unCBORBytes :: BS.ByteString}
  deriving (CBORBytes -> CBORBytes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CBORBytes -> CBORBytes -> Bool
$c/= :: CBORBytes -> CBORBytes -> Bool
== :: CBORBytes -> CBORBytes -> Bool
$c== :: CBORBytes -> CBORBytes -> Bool
Eq)

instance Show CBORBytes where
  show :: CBORBytes -> String
show = forall a. ToExpr a => a -> String
showExpr

instance ToExpr CBORBytes where
  toExpr :: CBORBytes -> Expr
toExpr (CBORBytes ByteString
bytes) =
    case forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes forall s. Decoder s Term
CBOR.decodeTerm (ByteString -> ByteString
BSL.fromStrict ByteString
bytes) of
      Left DeserialiseFailure
err ->
        String -> [Expr] -> Expr
App
          String
"CBORBytesError"
          [ forall a. ToExpr a => a -> Expr
toExpr @String String
"Error decoding CBOR, showing as Hex:"
          , forall a. ToExpr a => a -> Expr
toExpr (ByteString -> HexBytes
HexBytes ByteString
bytes)
          , forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show DeserialiseFailure
err
          ]
      Right (ByteString
leftOver, Term
term)
        | ByteString -> Bool
BSL.null ByteString
leftOver -> String -> [Expr] -> Expr
App String
"CBORBytes" [forall a. ToExpr a => a -> Expr
toExpr Term
term]
        | Bool
otherwise ->
            case forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
Plain.decodeFullDecoder Text
"Term" forall s. Decoder s Term
CBOR.decodeTerm ByteString
leftOver of
              Right Term
leftOverTerm ->
                String -> [Expr] -> Expr
App
                  String
"CBORBytesError"
                  [ forall a. ToExpr a => a -> Expr
toExpr @String String
"Error decoding CBOR fully:"
                  , forall a. ToExpr a => a -> Expr
toExpr Term
term
                  , forall a. ToExpr a => a -> Expr
toExpr @String String
"Leftover:"
                  , forall a. ToExpr a => a -> Expr
toExpr (Term
leftOverTerm :: Term)
                  ]
              Left DecoderError
err ->
                String -> [Expr] -> Expr
App
                  String
"CBORBytesError"
                  [ forall a. ToExpr a => a -> Expr
toExpr @String String
"Error decoding CBOR fully:"
                  , forall a. ToExpr a => a -> Expr
toExpr Term
term
                  , forall a. ToExpr a => a -> Expr
toExpr @String String
"Leftover as Hex, due to inabilty to decode as Term:"
                  , forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ ByteString -> HexBytes
HexBytes forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
leftOver
                  , forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall e. Buildable e => e -> String
showDecoderError DecoderError
err
                  ]

instance ToExpr Term where
  toExpr :: Term -> Expr
toExpr =
    \case
      TInt Int
i -> String -> [Expr] -> Expr
App String
"TInt" [forall a. ToExpr a => a -> Expr
toExpr Int
i]
      TInteger Integer
i -> String -> [Expr] -> Expr
App String
"TInteger" [forall a. ToExpr a => a -> Expr
toExpr Integer
i]
      TBytes ByteString
bs -> String -> [Expr] -> Expr
App String
"TBytes" forall a b. (a -> b) -> a -> b
$ ByteString -> [Expr]
hexByteStringExpr ByteString
bs
      TBytesI ByteString
bs -> String -> [Expr] -> Expr
App String
"TBytesI" forall a b. (a -> b) -> a -> b
$ ByteString -> [Expr]
hexByteStringExpr forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
bs
      TString Text
s -> String -> [Expr] -> Expr
App String
"TString" [forall a. ToExpr a => a -> Expr
toExpr Text
s]
      TStringI Text
s -> String -> [Expr] -> Expr
App String
"TStringI" [forall a. ToExpr a => a -> Expr
toExpr Text
s]
      TList [Term]
xs -> String -> [Expr] -> Expr
App String
"TList" [[Expr] -> Expr
Lst (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToExpr a => a -> Expr
toExpr [Term]
xs)]
      TListI [Term]
xs -> String -> [Expr] -> Expr
App String
"TListI" [[Expr] -> Expr
Lst (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToExpr a => a -> Expr
toExpr [Term]
xs)]
      TMap [(Term, Term)]
xs -> String -> [Expr] -> Expr
App String
"TMap" [[Expr] -> Expr
Lst (forall a b. (a -> b) -> [a] -> [b]
map (forall a. ToExpr a => a -> Expr
toExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. ToExpr a => a -> Expr
toExpr forall a. ToExpr a => a -> Expr
toExpr) [(Term, Term)]
xs)]
      TMapI [(Term, Term)]
xs -> String -> [Expr] -> Expr
App String
"TMapI" [[Expr] -> Expr
Lst (forall a b. (a -> b) -> [a] -> [b]
map (forall a. ToExpr a => a -> Expr
toExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. ToExpr a => a -> Expr
toExpr forall a. ToExpr a => a -> Expr
toExpr) [(Term, Term)]
xs)]
      TTagged Word64
24 (TBytes ByteString
x) -> String -> [Expr] -> Expr
App String
"CBOR-in-CBOR" [forall a. ToExpr a => a -> Expr
toExpr (ByteString -> CBORBytes
CBORBytes ByteString
x)]
      TTagged Word64
t Term
x -> String -> [Expr] -> Expr
App String
"TTagged" [forall a. ToExpr a => a -> Expr
toExpr Word64
t, forall a. ToExpr a => a -> Expr
toExpr Term
x]
      TBool Bool
x -> String -> [Expr] -> Expr
App String
"TBool" [forall a. ToExpr a => a -> Expr
toExpr Bool
x]
      Term
TNull -> String -> [Expr] -> Expr
App String
"TNull" []
      TSimple Word8
x -> String -> [Expr] -> Expr
App String
"TSimple" [forall a. ToExpr a => a -> Expr
toExpr Word8
x]
      THalf Float
x -> String -> [Expr] -> Expr
App String
"THalf" [forall a. ToExpr a => a -> Expr
toExpr Float
x]
      TFloat Float
x -> String -> [Expr] -> Expr
App String
"TFloat" [forall a. ToExpr a => a -> Expr
toExpr Float
x]
      TDouble Double
x -> String -> [Expr] -> Expr
App String
"TDouble" [forall a. ToExpr a => a -> Expr
toExpr Double
x]

hexByteStringExpr :: BS.ByteString -> [Expr]
hexByteStringExpr :: ByteString -> [Expr]
hexByteStringExpr ByteString
bs =
  [ forall a. ToExpr a => a -> Expr
toExpr (ByteString -> Int
BS.length ByteString
bs)
  , [Expr] -> Expr
Lst (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> [String]
showHexBytesGrouped Int
128 ByteString
bs)
  ]

-- | Show a ByteString as hex groups of 8bytes each. This is a slightly more
-- useful form for debugging, rather than bunch of escaped characters.
showHexBytesGrouped :: Int -> BS.ByteString -> [String]
showHexBytesGrouped :: Int -> ByteString -> [String]
showHexBytesGrouped Int
n ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs = []
  | Bool
otherwise =
      [ ByteString -> String
BS8.unpack (Int -> ByteString -> ByteString
BS.take Int
n forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
i ByteString
bs16)
      | Int
i <- [Int
0, Int
n .. ByteString -> Int
BS.length ByteString
bs16 forall a. Num a => a -> a -> a
- Int
1]
      ]
  where
    bs16 :: ByteString
bs16 = ByteString -> ByteString
Base16.encode ByteString
bs

-- | Check that two values are equal and if they are not raise an exception with the
-- `ToExpr` diff
expectExprEqual :: (Eq a, ToExpr a) => a -> a -> Expectation
expectExprEqual :: forall a. (Eq a, ToExpr a) => a -> a -> Expectation
expectExprEqual = forall a.
(ToExpr a, Eq a, HasCallStack) =>
String -> a -> a -> Expectation
expectExprEqualWithMessage String
"Expected two values to be equal:"

-- | Use this with HSpec, but with Tasty use 'assertExprEqualWithMessage' below
expectExprEqualWithMessage :: (ToExpr a, Eq a, HasCallStack) => String -> a -> a -> Expectation
expectExprEqualWithMessage :: forall a.
(ToExpr a, Eq a, HasCallStack) =>
String -> a -> a -> Expectation
expectExprEqualWithMessage = forall a b.
(ToExpr a, Eq a, Monoid b) =>
(Doc AnsiStyle -> b) -> Doc AnsiStyle -> a -> a -> b
requireExprEqualWithMessage (forall a. HasCallStack => String -> IO a
assertColorFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> String
ansiDocToString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
Pretty.pretty

-- | Use this with Tasty, but with HSpec use 'expectExprEqualWithMessage' above
assertExprEqualWithMessage :: (ToExpr a, Eq a, HasCallStack) => String -> a -> a -> Assertion
assertExprEqualWithMessage :: forall a.
(ToExpr a, Eq a, HasCallStack) =>
String -> a -> a -> Expectation
assertExprEqualWithMessage = forall a b.
(ToExpr a, Eq a, Monoid b) =>
(Doc AnsiStyle -> b) -> Doc AnsiStyle -> a -> a -> b
requireExprEqualWithMessage (forall a. HasCallStack => String -> IO a
assertFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> String
ansiDocToString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
Pretty.pretty

requireExprEqualWithMessage ::
  (ToExpr a, Eq a, Monoid b) => (Doc AnsiStyle -> b) -> Doc AnsiStyle -> a -> a -> b
requireExprEqualWithMessage :: forall a b.
(ToExpr a, Eq a, Monoid b) =>
(Doc AnsiStyle -> b) -> Doc AnsiStyle -> a -> a -> b
requireExprEqualWithMessage Doc AnsiStyle -> b
fail_ Doc AnsiStyle
message a
expected a
actual =
  if a
actual forall a. Eq a => a -> a -> Bool
== a
expected then forall a. Monoid a => a
mempty else Doc AnsiStyle -> b
fail_ Doc AnsiStyle
doc
  where
    doc :: Doc AnsiStyle
doc = forall ann. Doc ann -> (Int -> Doc ann) -> Doc ann
Pretty.width Doc AnsiStyle
message (\Int
w -> if Int
w forall a. Eq a => a -> a -> Bool
== Int
0 then Doc AnsiStyle
diff else forall ann. Doc ann
Pretty.line forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
Pretty.indent Int
2 Doc AnsiStyle
diff)
    diff :: Doc AnsiStyle
diff = forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr a
expected a
actual