{-# 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)


-- | Test that a pair of encode / decode functions are compatible.
--
-- Given a printer from some type @a -> b@, and a parser with a
-- potential failure case @b -> f a@. Ensure that a valid @a@ round
-- trips through the "print" and "parse" to yield the same @a@.
--
-- For example, types /should/ have tripping 'Read' and 'Show'
-- instances:
--
-- @
-- trippingShowRead :: (Show a, Read a, Eq a, MonadTest m) => a -> m ()
-- trippingShowRead a = tripping a show readEither
-- @
tripping ::
     (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack)
  => a
  -> (a -> b)
  -> (b -> f a)
  -> m ()
tripping :: forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
tripping a
x a -> b
encode b -> f a
decode =
  let
    mx :: f a
mx =
      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 forall a. Eq a => a -> a -> Bool
== f a
my then
      forall (m :: * -> *). MonadTest m => m ()
success
    else
      case Value -> Value -> ValueDiff
valueDiff forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Show a => a -> Maybe Value
mkValue f a
mx forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Show a => a -> Maybe Value
mkValue f a
my of
        Maybe ValueDiff
Nothing ->
          forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
                String
"━━━ Original ━━━"
              , forall a. Show a => a -> String
showPretty f a
mx
              , String
"━━━ Intermediate ━━━"
              , forall a. Show a => a -> String
showPretty b
i
              , String
"━━━ Roundtrip ━━━"
              , forall a. Show a => a -> String
showPretty f a
my
              ]

        Just ValueDiff
diff ->
          forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith
              (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                String -> String -> String -> String -> String -> ValueDiff -> Diff
Diff String
"━━━ " String
"- Original" String
") (" String
"+ Roundtrip" String
" ━━━" ValueDiff
diff) forall a b. (a -> b) -> a -> b
$
              [String] -> String
unlines [
                  String
"━━━ Intermediate ━━━"
                , forall a. Show a => a -> String
showPretty b
i
                ]