{-# 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 = a -> Expr
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 = ((String, Doc AnsiStyle) -> Int -> Int)
-> Int -> [(String, Doc AnsiStyle)] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> Int -> Int)
-> ((String, Doc AnsiStyle) -> Int)
-> (String, Doc AnsiStyle)
-> Int
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, Doc AnsiStyle) -> String)
-> (String, Doc AnsiStyle)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Doc AnsiStyle) -> String
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 -> [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
Pretty.hsep [Doc AnsiStyle
"-----", Doc AnsiStyle
title, Doc AnsiStyle
"-----"] Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
Pretty.line
        Maybe (Doc AnsiStyle)
Nothing -> Doc AnsiStyle
forall a. Monoid a => a
mempty
   in Doc AnsiStyle
t Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
Pretty.vsep [Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
Pretty.fill (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
Pretty.pretty String
l) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
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 = Int -> Hash c index -> Expr
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 = Int -> SignedDSIGN c index -> Expr
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" [[a] -> Expr
forall a. ToExpr a => [a] -> Expr
listToExpr (StrictSeq a -> [a]
forall a. StrictSeq a -> [a]
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" [Word64 -> Expr
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 = 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
prettyExpr (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

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

ansiExprString :: ToExpr a => a -> String
ansiExprString :: forall a. ToExpr a => a -> String
ansiExprString = Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> (a -> Doc AnsiStyle) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc AnsiStyle
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 (a -> a -> Edit EditExpr
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 (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$ a -> a -> Doc AnsiStyle
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 (a -> a -> Edit EditExpr
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 (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$ a -> a -> Doc AnsiStyle
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
(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 :: 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 Term where
  toExpr :: Term -> Expr
toExpr =
    \case
      TInt Int
i -> String -> [Expr] -> Expr
App String
"TInt" [Int -> Expr
forall a. ToExpr a => a -> Expr
toExpr Int
i]
      TInteger Integer
i -> String -> [Expr] -> Expr
App String
"TInteger" [Integer -> Expr
forall a. ToExpr a => a -> Expr
toExpr Integer
i]
      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
      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
      TString Text
s -> String -> [Expr] -> Expr
App String
"TString" [Text -> Expr
forall a. ToExpr a => a -> Expr
toExpr Text
s]
      TStringI Text
s -> String -> [Expr] -> Expr
App String
"TStringI" [Text -> Expr
forall a. ToExpr a => a -> Expr
toExpr Text
s]
      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)]
      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)]
      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)]
      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)]
      TTagged Word64
24 (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)]
      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]
      TBool Bool
x -> String -> [Expr] -> Expr
App String
"TBool" [Bool -> Expr
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" [Word8 -> Expr
forall a. ToExpr a => a -> Expr
toExpr Word8
x]
      THalf Float
x -> String -> [Expr] -> Expr
App String
"THalf" [Float -> Expr
forall a. ToExpr a => a -> Expr
toExpr Float
x]
      TFloat Float
x -> String -> [Expr] -> Expr
App String
"TFloat" [Float -> Expr
forall a. ToExpr a => a -> Expr
toExpr Float
x]
      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
$ 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 (ByteString -> ByteString) -> ByteString -> ByteString
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 Int -> Int -> Int
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 = String -> a -> a -> Expectation
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 = (Doc AnsiStyle -> Expectation)
-> Doc AnsiStyle -> a -> a -> Expectation
forall a b.
(ToExpr a, Eq a, Monoid b) =>
(Doc AnsiStyle -> b) -> Doc AnsiStyle -> a -> a -> b
requireExprEqualWithMessage (String -> Expectation
forall a. HasCallStack => String -> IO a
assertColorFailure (String -> Expectation)
-> (Doc AnsiStyle -> String) -> Doc AnsiStyle -> Expectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> String
ansiDocToString) (Doc AnsiStyle -> a -> a -> Expectation)
-> (String -> Doc AnsiStyle) -> String -> a -> a -> Expectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc AnsiStyle
forall ann. String -> Doc ann
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 = (Doc AnsiStyle -> Expectation)
-> Doc AnsiStyle -> a -> a -> Expectation
forall a b.
(ToExpr a, Eq a, Monoid b) =>
(Doc AnsiStyle -> b) -> Doc AnsiStyle -> a -> a -> b
requireExprEqualWithMessage (String -> Expectation
forall a. HasCallStack => String -> IO a
assertFailure (String -> Expectation)
-> (Doc AnsiStyle -> String) -> Doc AnsiStyle -> Expectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> String
ansiDocToString) (Doc AnsiStyle -> a -> a -> Expectation)
-> (String -> Doc AnsiStyle) -> String -> a -> a -> Expectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc AnsiStyle
forall ann. String -> Doc ann
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected then b
forall a. Monoid a => a
mempty else Doc AnsiStyle -> b
fail_ Doc AnsiStyle
doc
  where
    doc :: Doc AnsiStyle
doc = Doc AnsiStyle -> (Int -> Doc AnsiStyle) -> Doc AnsiStyle
forall ann. Doc ann -> (Int -> Doc ann) -> Doc ann
Pretty.width Doc AnsiStyle
message (\Int
w -> if Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Doc AnsiStyle
diff else Doc AnsiStyle
forall ann. Doc ann
Pretty.line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
Pretty.indent Int
2 Doc AnsiStyle
diff)
    diff :: Doc AnsiStyle
diff = a -> a -> Doc AnsiStyle
forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr a
expected a
actual