{-# 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 = forall a. Format String a -> a
formatToString forall a r. Buildable a => Format r (a -> r)
build

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
ansiWlExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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 :: CBOR.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 CBOR.Term where
  toExpr :: Term -> Expr
toExpr =
    \case
      CBOR.TInt Int
i -> String -> [Expr] -> Expr
App String
"TInt" [forall a. ToExpr a => a -> Expr
toExpr Int
i]
      CBOR.TInteger Integer
i -> String -> [Expr] -> Expr
App String
"TInteger" [forall a. ToExpr a => a -> Expr
toExpr Integer
i]
      CBOR.TBytes ByteString
bs -> String -> [Expr] -> Expr
App String
"TBytes" forall a b. (a -> b) -> a -> b
$ ByteString -> [Expr]
hexByteStringExpr ByteString
bs
      CBOR.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
      CBOR.TString Text
s -> String -> [Expr] -> Expr
App String
"TString" [forall a. ToExpr a => a -> Expr
toExpr Text
s]
      CBOR.TStringI Text
s -> String -> [Expr] -> Expr
App String
"TStringI" [forall a. ToExpr a => a -> Expr
toExpr Text
s]
      CBOR.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)]
      CBOR.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)]
      CBOR.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)]
      CBOR.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)]
      CBOR.TTagged Word64
24 (CBOR.TBytes ByteString
x) -> String -> [Expr] -> Expr
App String
"CBOR-in-CBOR" [forall a. ToExpr a => a -> Expr
toExpr (ByteString -> CBORBytes
CBORBytes ByteString
x)]
      CBOR.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]
      CBOR.TBool Bool
x -> String -> [Expr] -> Expr
App String
"TBool" [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" [forall a. ToExpr a => a -> Expr
toExpr Word8
x]
      CBOR.THalf Float
x -> String -> [Expr] -> Expr
App String
"THalf" [forall a. ToExpr a => a -> Expr
toExpr Float
x]
      CBOR.TFloat Float
x -> String -> [Expr] -> Expr
App String
"TFloat" [forall a. ToExpr a => a -> Expr
toExpr Float
x]
      CBOR.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
$ 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" forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS8.unpack (Int -> ByteString -> ByteString
BS.take Int
128 ByteString
bs16))
        forall a. a -> [a] -> [a]
: [ String
"  " forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS8.unpack (Int -> ByteString -> ByteString
BS.take Int
128 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 forall a. Num a => a -> a -> a
- Int
1]
          ]
  where
    bs16 :: ByteString
bs16 = ByteString -> ByteString
Base16.encode ByteString
bs