{-# 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 :: 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 ]