{-# OPTIONS_HADDOCK not-home #-}
module Hedgehog.Internal.Tripping (
tripping
) where
import Hedgehog.Internal.Property (MonadTest, Diff(..), success, failWith)
import Hedgehog.Internal.Show (valueDiff, mkValue, showPretty)
import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
tripping ::
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack)
=> a
-> (a -> b)
-> (b -> f a)
-> m ()
tripping :: a -> (a -> b) -> (b -> f a) -> m ()
tripping a
x a -> b
encode b -> f a
decode =
let
mx :: f a
mx =
a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
i :: b
i =
a -> b
encode a
x
my :: f a
my =
b -> f a
decode b
i
in
if f a
mx f a -> f a -> Bool
forall a. Eq a => a -> a -> Bool
== f a
my then
m ()
forall (m :: * -> *). MonadTest m => m ()
success
else
case Value -> Value -> ValueDiff
valueDiff (Value -> Value -> ValueDiff)
-> Maybe Value -> Maybe (Value -> ValueDiff)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue f a
mx Maybe (Value -> ValueDiff) -> Maybe Value -> Maybe ValueDiff
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue f a
my of
Maybe ValueDiff
Nothing ->
(HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
String
"━━━ Original ━━━"
, f a -> String
forall a. Show a => a -> String
showPretty f a
mx
, String
"━━━ Intermediate ━━━"
, b -> String
forall a. Show a => a -> String
showPretty b
i
, String
"━━━ Roundtrip ━━━"
, f a -> String
forall a. Show a => a -> String
showPretty f a
my
]
Just ValueDiff
diff ->
(HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith
(Diff -> Maybe Diff
forall a. a -> Maybe a
Just (Diff -> Maybe Diff) -> Diff -> Maybe Diff
forall a b. (a -> b) -> a -> b
$
String -> String -> String -> String -> String -> ValueDiff -> Diff
Diff String
"━━━ " String
"- Original" String
") (" String
"+ Roundtrip" String
" ━━━" ValueDiff
diff) (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines [
String
"━━━ Intermediate ━━━"
, b -> String
forall a. Show a => a -> String
showPretty b
i
]