Add TreeDiff utilities to cardano-binary testlib

cardano-binary/CHANGELOG.md

@@ -11,6 +11,13 @@
 ### `testlib`
 
 * Add `Arbitrary` instances for `ByteArray`, `SlicedByteArray` and `Term` from `cborg`
+* Add TreeDiff utility functions from `cardano-ledger-binary:testlib`:
+  `ansiExpr`, `diffExpr`, `diffExprCompact`, `expectExprEqual`,
+  `requireExprEqualWithMessage`, `trimExprViaShow`, `tableDoc`
+* Add `ToExpr` orphan instances for `DecoderError` and `DeserialiseFailure`
+* Add re-exports from `ImpSpec`, `prettyprinter`, and `tree-diff` for convenience
+* Change `showHexBytesGrouped` to accept a configurable group size parameter
+* Change `showExpr` to use `prettyExpr` (plain text) instead of `ansiWlExpr` (ANSI colored)
 
 ## 1.8.0.0
 

cardano-binary/cardano-binary.cabal

@@ -73,6 +73,7 @@ library testlib
     Test.Cardano.Binary.TreeDiff
 
   build-depends:
+    ImpSpec,
     QuickCheck,
     base,
     base16-bytestring,
@@ -87,6 +88,8 @@ library testlib
     hedgehog,
     hspec,
     pretty-show,
+    prettyprinter,
+    prettyprinter-ansi-terminal,
     quickcheck-instances,
     text,
     tree-diff,

cardano-binary/testlib/Test/Cardano/Binary/TreeDiff.hs

@@ -1,27 +1,110 @@
+{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Test.Cardano.Binary.TreeDiff where
+module Test.Cardano.Binary.TreeDiff (
+  -- * Diffing and pretty printing
+  ToExpr (..),
+  showExpr,
+  ansiExpr,
+  ansiExprString,
+  diffExpr,
+  diffExprString,
+  diffExprCompact,
+  diffExprCompactString,
 
-import qualified Cardano.Binary as Plain
-import qualified Codec.CBOR.Read as CBOR
+  -- * Test expectations
+  expectExprEqual,
+  expectExprEqualWithMessage,
+  requireExprEqualWithMessage,
+
+  -- * Utility functions
+  trimExprViaShow,
+  tableDoc,
+  hexByteStringExpr,
+  showHexBytesGrouped,
+
+  -- * Newtypes for debugging
+  CBORBytes (..),
+  HexBytes (..),
+
+) where
+
+import Cardano.Binary
+import Codec.CBOR.Read (DeserialiseFailure (..), deserialiseFromBytes)
 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 (..))
+import GHC.Stack (HasCallStack)
+import Prettyprinter (Doc)
+import qualified Prettyprinter as Pretty
+import Prettyprinter.Render.Terminal (AnsiStyle)
+import Test.Hspec (Expectation)
+import Test.ImpSpec (ansiDocToString)
+import Test.ImpSpec.Expectations (assertColorFailure, callStackToLocation, srcLocToLocation)
+
+-- =====================================================
+-- Utility functions for TreeDiff and ToExpr
+
+trimExprViaShow :: Show a => Int -> a -> Expr
+trimExprViaShow _n x = defaultExprViaShow x
+
+tableDoc :: Maybe (Doc AnsiStyle) -> [(String, Doc AnsiStyle)] -> Doc AnsiStyle
+tableDoc mTitle rows =
+  let w = foldr (max . length . fst) 0 rows
+      t = case mTitle of
+        Just title -> Pretty.hsep ["-----", title, "-----"] <> Pretty.line
+        Nothing -> mempty
+   in t <> Pretty.vsep [Pretty.fill (w + 1) (Pretty.pretty l) <> r | (l, r) <- rows]
 
-showDecoderError :: B.Buildable e => e -> String
-showDecoderError = formatToString build
+-- =====================================================
+-- Orphan ToExpr instances for cardano-binary types
+
+instance ToExpr Plain.DecoderError where
+  toExpr (Plain.DecoderErrorCanonicityViolation x) = App "DecoderErrorCanonicityViolation" [toExpr x]
+  toExpr (Plain.DecoderErrorCustom x y) = App "DecoderErrorCustom" [toExpr x, toExpr y]
+  toExpr (Plain.DecoderErrorDeserialiseFailure x y) = App "DecoderErrorDeserialiseFailure" [toExpr x, toExpr y]
+  toExpr (Plain.DecoderErrorEmptyList x) = App "DecoderErrorEmptyList" [toExpr x]
+  toExpr (Plain.DecoderErrorLeftover x y) = App "DecoderErrorLeftover" [toExpr x, toExpr y]
+  toExpr (Plain.DecoderErrorSizeMismatch x y z) = App "DecoderErrorSizeMismatch" [toExpr x, toExpr y, toExpr z]
+  toExpr (Plain.DecoderErrorUnknownTag x y) = App "DecoderErrorUnknownTag" [toExpr x, toExpr y]
+  toExpr Plain.DecoderErrorVoid = App "DecoderErrorVoid" []
+
+instance ToExpr DeserialiseFailure where
+  toExpr (DeserialiseFailure x y) = App "DeserialiseFailure" [toExpr x, toExpr y]
+
+-- =====================================================
+-- Diffing and pretty showing
 
 showExpr :: ToExpr a => a -> String
-showExpr = show . ansiWlExpr . toExpr
+showExpr = show . prettyExpr . toExpr
+
+ansiExpr :: ToExpr a => a -> Doc AnsiStyle
+ansiExpr = ansiWlExpr . toExpr
+
+ansiExprString :: ToExpr a => a -> String
+ansiExprString = ansiDocToString . ansiExpr
+
+diffExpr :: ToExpr a => a -> a -> Doc AnsiStyle
+diffExpr x y = ansiWlEditExpr (ediff x y)
+
+diffExprString :: ToExpr a => a -> a -> String
+diffExprString x y = ansiDocToString $ diffExpr x y
+
+diffExprCompact :: ToExpr a => a -> a -> Doc AnsiStyle
+diffExprCompact x y = ansiWlEditExprCompact (ediff x y)
+
+diffExprCompactString :: ToExpr a => a -> a -> String
+diffExprCompactString x y = ansiDocToString $ diffExprCompact x y
+
+-- =====================================================
+-- Hex and CBOR byte debugging newtypes
 
 -- | Wraps regular ByteString, but shows and diffs it as hex
 newtype HexBytes = HexBytes {unHexBytes :: BS.ByteString}
@@ -41,7 +124,7 @@ instance Show CBORBytes where
 
 instance ToExpr CBORBytes where
   toExpr (CBORBytes bytes) =
-    case CBOR.deserialiseFromBytes CBOR.decodeTerm (BSL.fromStrict bytes) of
+    case deserialiseFromBytes CBOR.decodeTerm (BSL.fromStrict bytes) of
       Left err ->
         App
           "CBORBytesError"
@@ -96,18 +179,42 @@ instance ToExpr CBOR.Term where
 hexByteStringExpr :: BS.ByteString -> [Expr]
 hexByteStringExpr bs =
   [ toExpr (BS.length bs)
-  , Lst (map toExpr $ showHexBytesGrouped bs)
+  , Lst (map toExpr $ showHexBytesGrouped 128 bs)
   ]
 
--- | Show a ByteString as hex groups of 8bytes each. This is a slightly more
+-- | Show a ByteString as hex groups of N characters each. This is a slightly more
 -- useful form for debugging, rather than bunch of escaped characters.
-showHexBytesGrouped :: BS.ByteString -> [String]
-showHexBytesGrouped bs
+showHexBytesGrouped :: Int -> BS.ByteString -> [String]
+showHexBytesGrouped n bs
   | BS.null bs = []
   | otherwise =
-      ("0x" <> BS8.unpack (BS.take 128 bs16))
-        : [ "  " <> BS8.unpack (BS.take 128 $ BS.drop i bs16)
-          | i <- [128, 256 .. BS.length bs16 - 1]
-          ]
+      [ BS8.unpack (BS.take n $ BS.drop i bs16)
+      | i <- [0, n .. BS.length bs16 - 1]
+      ]
   where
     bs16 = Base16.encode bs
+
+-- =====================================================
+-- Test expectations
+
+-- | 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 = expectExprEqualWithMessage "Expected two values to be equal:"
+
+expectExprEqualWithMessage :: (ToExpr a, Eq a, HasCallStack) => String -> a -> a -> Expectation
+expectExprEqualWithMessage = requireExprEqualWithMessage (assertColorFailure . ansiDocToString) . Pretty.pretty
+
+requireExprEqualWithMessage ::
+  (ToExpr a, Eq a, Monoid b) => (Doc AnsiStyle -> b) -> Doc AnsiStyle -> a -> a -> b
+requireExprEqualWithMessage fail_ message expected actual =
+  if actual == expected then mempty else fail_ doc
+  where
+    doc = Pretty.width message (\w -> if w == 0 then diff else Pretty.line <> Pretty.indent 2 diff)
+    diff = diffExpr actual expected
+
+-- =====================================================
+-- Internal helpers
+
+showDecoderError :: Plain.DecoderError -> String
+showDecoderError = show