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

module Test.Cardano.Binary.TreeDiff where

import qualified Cardano.Binary as Plain
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.TreeDiff
import Formatting (build, formatToString)
import qualified Formatting.Buildable as B (Buildable (..))

showDecoderError :: B.Buildable e => e -> String
showDecoderError :: forall e. Buildable e => e -> String
showDecoderError = Format String (e -> String) -> e -> String
forall a. Format String a -> a
formatToString Format String (e -> String)
forall a r. Buildable a => Format r (a -> r)
build

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

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

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

instance ToExpr HexBytes where
  toExpr :: HexBytes -> Expr
toExpr = String -> [Expr] -> Expr
App String
"HexBytes" ([Expr] -> Expr) -> (HexBytes -> [Expr]) -> HexBytes -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Expr]
hexByteStringExpr (ByteString -> [Expr])
-> (HexBytes -> ByteString) -> HexBytes -> [Expr]
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
(CBORBytes -> CBORBytes -> Bool)
-> (CBORBytes -> CBORBytes -> Bool) -> Eq CBORBytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CBORBytes -> CBORBytes -> Bool
== :: CBORBytes -> CBORBytes -> Bool
$c/= :: CBORBytes -> CBORBytes -> Bool
/= :: CBORBytes -> CBORBytes -> Bool
Eq)

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

instance ToExpr CBORBytes where
  toExpr :: CBORBytes -> Expr
toExpr (CBORBytes ByteString
bytes) =
    case (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes Decoder s Term
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:"
          , HexBytes -> Expr
forall a. ToExpr a => a -> Expr
toExpr (ByteString -> HexBytes
HexBytes ByteString
bytes)
          , String -> Expr
forall a. ToExpr a => a -> Expr
toExpr (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> String
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" [Term -> Expr
forall a. ToExpr a => a -> Expr
toExpr Term
term]
        | Bool
otherwise ->
            case Text
-> (forall s. Decoder s Term)
-> ByteString
-> Either DecoderError Term
forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
Plain.decodeFullDecoder Text
"Term" Decoder s 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:"
                  , Term -> Expr
forall a. ToExpr a => a -> Expr
toExpr Term
term
                  , forall a. ToExpr a => a -> Expr
toExpr @String String
"Leftover:"
                  , Term -> Expr
forall a. ToExpr a => a -> Expr
toExpr (Term
leftOverTerm :: CBOR.Term)
                  ]
              Left DecoderError
err ->
                String -> [Expr] -> Expr
App
                  String
"CBORBytesError"
                  [ forall a. ToExpr a => a -> Expr
toExpr @String String
"Error decoding CBOR fully:"
                  , Term -> Expr
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:"
                  , HexBytes -> Expr
forall a. ToExpr a => a -> Expr
toExpr (HexBytes -> Expr) -> HexBytes -> Expr
forall a b. (a -> b) -> a -> b
$ ByteString -> HexBytes
HexBytes (ByteString -> HexBytes) -> ByteString -> HexBytes
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
leftOver
                  , String -> Expr
forall a. ToExpr a => a -> Expr
toExpr (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ DecoderError -> String
forall e. Buildable e => e -> String
showDecoderError DecoderError
err
                  ]

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

hexByteStringExpr :: BS.ByteString -> [Expr]
hexByteStringExpr :: ByteString -> [Expr]
hexByteStringExpr ByteString
bs =
  [ Int -> Expr
forall a. ToExpr a => a -> Expr
toExpr (ByteString -> Int
BS.length ByteString
bs)
  , [Expr] -> Expr
Lst ((String -> Expr) -> [String] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([String] -> [Expr]) -> [String] -> [Expr]
forall a b. (a -> b) -> a -> b
$ ByteString -> [String]
showHexBytesGrouped 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 :: BS.ByteString -> [String]
showHexBytesGrouped :: ByteString -> [String]
showHexBytesGrouped ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs = []
  | Bool
otherwise =
      (String
"0x" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS8.unpack (Int -> ByteString -> ByteString
BS.take Int
128 ByteString
bs16))
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS8.unpack (Int -> ByteString -> ByteString
BS.take Int
128 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
i ByteString
bs16)
          | Int
i <- [Int
128, Int
256 .. ByteString -> Int
BS.length ByteString
bs16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
          ]
  where
    bs16 :: ByteString
bs16 = ByteString -> ByteString
Base16.encode ByteString
bs