-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Testing utility functions used by testing framework itself or
-- intended to be used by test writers.

module Michelson.Test.Util
  ( leftToShowPanic
  , leftToPrettyPanic
  , failedTest
  , succeededTest
  , eitherIsLeft
  , eitherIsRight
  , total
  , meanTimeUpperBoundProp
  , meanTimeUpperBoundPropNF
  , genEither
  , genTuple2
  , runGen
  , roundtripTree

  -- * Re-exports
  --
  -- | These functions from "Time" are re-exported here to make it convenient to call
  -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'.
  , mcs, ms, sec, minute

  -- * Deprecated
  , failedProp
  , succeededProp
  , qcIsLeft
  , qcIsRight
  , roundtripTest
  ) where

import Criterion (Benchmarkable, benchmarkWith', nf, whnf)
import Criterion.Main (defaultConfig)
import Criterion.Types (SampleAnalysis(anMean), Verbosity(Quiet), reportAnalysis, verbosity)
import Data.Typeable (typeRep)
import Fmt (Buildable, pretty)
import Hedgehog
  (Gen, MonadGen, MonadTest, Property, annotate, eval, evalIO, failure, forAll, property, success,
  tripping, withTests)
import qualified Hedgehog.Gen as Gen
import Hedgehog.Internal.Gen (runGenT)
import qualified Hedgehog.Internal.Seed as Seed
import Hedgehog.Internal.Tree (TreeT(runTreeT), nodeValue)
import qualified Hedgehog.Range as Range
import Statistics.Types (Estimate(estPoint))
import Test.QuickCheck (Arbitrary)
import qualified Test.QuickCheck.Property as QC
import Test.Tasty (TestTree)
import Test.Tasty.Hedgehog (testProperty)
import qualified Test.Tasty.QuickCheck as TQC
import Text.Printf (printf)
import Time
  (KnownDivRat, KnownUnitName, Microsecond, Millisecond, Minute, Nanosecond, Picosecond, RatioNat,
  Second, Time, mcs, minute, ms, ns, sec, timeout, toUnit, unTime, unitNameVal)

leftToShowPanic :: (Show e, HasCallStack) => Either e a -> a
leftToShowPanic :: Either e a -> a
leftToShowPanic = (e -> a) -> (a -> a) -> Either e a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> a
forall a. HasCallStack => Text -> a
error (Text -> a) -> (e -> Text) -> e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Text
forall b a. (Show a, IsString b) => a -> b
show) a -> a
forall a. a -> a
id

leftToPrettyPanic :: (Buildable e, HasCallStack) => Either e a -> a
leftToPrettyPanic :: Either e a -> a
leftToPrettyPanic = (e -> a) -> (a -> a) -> Either e a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> a
forall a. HasCallStack => Text -> a
error (Text -> a) -> (e -> Text) -> e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) a -> a
forall a. a -> a
id

----------------------------------------------------------------------------
-- Property
----------------------------------------------------------------------------

-- | A 'QC.Property' that always fails with given message.
failedProp :: Text -> QC.Property
failedProp :: Text -> Property
failedProp r :: Text
r = Result -> Property
forall prop. Testable prop => prop -> Property
QC.property (Result -> Property) -> Result -> Property
forall a b. (a -> b) -> a -> b
$ Result
QC.failed { reason :: String
QC.reason = Text -> String
forall a. ToString a => a -> String
toString Text
r }
{-# DEPRECATED failedProp "Use 'failedtest' instead." #-}

-- | A 'QC.Property' that always succeeds.
succeededProp :: QC.Property
succeededProp :: Property
succeededProp = Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True
{-# DEPRECATED succeededProp "Use 'succeededTest' instead." #-}

-- | The 'QC.Property' holds on `Left a`.
qcIsLeft :: Show b => Either a b -> QC.Property
qcIsLeft :: Either a b -> Property
qcIsLeft = \case
  Left _ -> Property
succeededProp
  Right x :: b
x -> Text -> Property
failedProp (Text -> Property) -> Text -> Property
forall a b. (a -> b) -> a -> b
$ "expected Left, got Right (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> b -> Text
forall b a. (Show a, IsString b) => a -> b
show b
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
{-# DEPRECATED qcIsLeft "Use 'eitherIsLeft' instead." #-}

-- | The 'QC.Property' holds on `Right b`.
qcIsRight :: Show a => Either a b -> QC.Property
qcIsRight :: Either a b -> Property
qcIsRight = \case
  Right _ -> Property
succeededProp
  Left x :: a
x -> Text -> Property
failedProp (Text -> Property) -> Text -> Property
forall a b. (a -> b) -> a -> b
$ "expected Right, got Left (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
{-# DEPRECATED qcIsRight "Use 'eitherIsRight' instead." #-}

-- | A 'Property' that always fails with given message.
failedTest :: (HasCallStack, MonadTest m) => Text -> m ()
failedTest :: Text -> m ()
failedTest r :: Text
r = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (Text -> String
forall a. ToString a => a -> String
toString Text
r) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure

-- | A 'Property' that always succeeds.
succeededTest :: MonadTest m => m ()
succeededTest :: m ()
succeededTest = m ()
forall (m :: * -> *). MonadTest m => m ()
success

-- | The 'Property' holds on `Left a`.
eitherIsLeft :: (Show b, MonadTest m, HasCallStack) => Either a b -> m ()
eitherIsLeft :: Either a b -> m ()
eitherIsLeft = \case
  Left _ -> m ()
forall (m :: * -> *). MonadTest m => m ()
succeededTest
  Right x :: b
x -> (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadTest m) => Text -> m ()
failedTest (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "expected Left, got Right (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> b -> Text
forall b a. (Show a, IsString b) => a -> b
show b
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

-- | The 'Property' holds on `Right b`.
eitherIsRight :: (Show a, MonadTest m, HasCallStack) => Either a b -> m ()
eitherIsRight :: Either a b -> m ()
eitherIsRight = \case
  Right _ -> m ()
forall (m :: * -> *). MonadTest m => m ()
succeededTest
  Left x :: a
x -> (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadTest m) => Text -> m ()
failedTest (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "expected Right, got Left (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

-- | Checks that a value is total, i.e., doesn't crash when evaluated,
-- by reducing it to its normal form.
--
-- Equivalent to QuickCheck's @total@.
total :: (MonadTest m, NFData a, HasCallStack) => a -> m a
total :: a -> m a
total a :: a
a = ((HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
eval (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$ a -> ()
forall a. NFData a => a -> ()
rnf a
a) m () -> a -> m a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
a

-- | Benchmarks the given function and checks that the mean time to evaluate to weak head
-- normal form is under the given amount of time.
--
-- This test fails if the benchmark takes longer than 30 seconds to run.
meanTimeUpperBoundProp
  :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack)
  => Time unit -> (a -> b) -> a -> Property
meanTimeUpperBoundProp :: Time unit -> (a -> b) -> a -> Property
meanTimeUpperBoundProp upperBound :: Time unit
upperBound run :: a -> b
run arg :: a
arg =
  (HasCallStack => Property) -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Property) -> Property)
-> (HasCallStack => Property) -> Property
forall a b. (a -> b) -> a -> b
$
    Time unit -> Benchmarkable -> Property
forall (unit :: Rat).
(KnownDivRat unit Second, KnownUnitName unit, HasCallStack) =>
Time unit -> Benchmarkable -> Property
checkReport Time unit
upperBound (Benchmarkable -> Property) -> Benchmarkable -> Property
forall a b. (a -> b) -> a -> b
$ (a -> b) -> a -> Benchmarkable
forall a b. (a -> b) -> a -> Benchmarkable
whnf a -> b
run a
arg

-- | Benchmarks the given function and checks that the mean time to evaluate to
-- normal form is under the given amount of time.
--
-- This test aborts and fails if the benchmark takes longer than 120 seconds to run.
meanTimeUpperBoundPropNF
  :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack, NFData b)
  => Time unit -> (a -> b) -> a -> Property
meanTimeUpperBoundPropNF :: Time unit -> (a -> b) -> a -> Property
meanTimeUpperBoundPropNF upperBound :: Time unit
upperBound run :: a -> b
run arg :: a
arg =
  (HasCallStack => Property) -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Property) -> Property)
-> (HasCallStack => Property) -> Property
forall a b. (a -> b) -> a -> b
$
    Time unit -> Benchmarkable -> Property
forall (unit :: Rat).
(KnownDivRat unit Second, KnownUnitName unit, HasCallStack) =>
Time unit -> Benchmarkable -> Property
checkReport Time unit
upperBound (Benchmarkable -> Property) -> Benchmarkable -> Property
forall a b. (a -> b) -> a -> b
$ (a -> b) -> a -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf a -> b
run a
arg

checkReport
  :: (KnownDivRat unit Second, KnownUnitName unit)
  => HasCallStack => Time unit -> Benchmarkable -> Property
checkReport :: Time unit -> Benchmarkable -> Property
checkReport upperBound :: Time unit
upperBound benchmarkable :: Benchmarkable
benchmarkable =
  TestLimit -> Property -> Property
withTests 1 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$
    IO (Maybe Report) -> PropertyT IO (Maybe Report)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO IO (Maybe Report)
runBench PropertyT IO (Maybe Report)
-> (Maybe Report -> PropertyT IO ()) -> PropertyT IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Nothing -> Text -> PropertyT IO ()
forall (m :: * -> *). (HasCallStack, MonadTest m) => Text -> m ()
failedTest "Expected benchmark to complete within 120 seconds."
      Just report :: Report
report ->
        let mean :: Time (1 :% 1)
mean = RatioNat -> Time (1 :% 1)
RatioNat -> Time Second
sec (RatioNat -> Time (1 :% 1))
-> (SampleAnalysis -> RatioNat) -> SampleAnalysis -> Time (1 :% 1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Real Double, Fractional RatioNat) => Double -> RatioNat
forall a b. (Real a, Fractional b) => a -> b
realToFrac @Double @RatioNat (Double -> RatioNat)
-> (SampleAnalysis -> Double) -> SampleAnalysis -> RatioNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Estimate ConfInt Double -> Double
forall (e :: * -> *) a. Estimate e a -> a
estPoint (Estimate ConfInt Double -> Double)
-> (SampleAnalysis -> Estimate ConfInt Double)
-> SampleAnalysis
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SampleAnalysis -> Estimate ConfInt Double
anMean (SampleAnalysis -> Time (1 :% 1))
-> SampleAnalysis -> Time (1 :% 1)
forall a b. (a -> b) -> a -> b
$ Report -> SampleAnalysis
reportAnalysis Report
report
        in  if Time (1 :% 1)
mean Time (1 :% 1) -> Time (1 :% 1) -> Bool
forall a. Ord a => a -> a -> Bool
< Time unit -> Time Second
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Second Time unit
upperBound
              then PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
succeededTest
              else Text -> PropertyT IO ()
forall (m :: * -> *). (HasCallStack, MonadTest m) => Text -> m ()
failedTest (Text -> PropertyT IO ()) -> Text -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$
                "Expected mean estimate to be under "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time unit -> Text
forall b a. (Show a, IsString b) => a -> b
show Time unit
upperBound
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ", but was "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time Second -> Text
display Time (1 :% 1)
Time Second
mean
  where
    runBench :: IO (Maybe Report)
runBench = Time (60 :% 1) -> IO Report -> IO (Maybe Report)
forall (unit :: Rat) (m :: * -> *) a.
(MonadIO m, KnownDivRat unit Microsecond) =>
Time unit -> IO a -> m (Maybe a)
timeout (RatioNat -> Time Minute
minute 2) (IO Report -> IO (Maybe Report)) -> IO Report -> IO (Maybe Report)
forall a b. (a -> b) -> a -> b
$
      Config -> Benchmarkable -> IO Report
benchmarkWith' (Config
defaultConfig { verbosity :: Verbosity
verbosity = Verbosity
Quiet }) Benchmarkable
benchmarkable

    display :: Time Second -> Text
    display :: Time Second -> Text
display n :: Time Second
n = case Time Second
n of
      (forall (unitFrom :: Rat).
KnownDivRat unitFrom Minute =>
Time unitFrom -> Time Minute
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Minute -> Time Minute
x) | Time (60 :% 1)
Time Minute
x Time (60 :% 1) -> Time (60 :% 1) -> Bool
forall a. Ord a => a -> a -> Bool
> RatioNat -> Time Minute
minute 1 -> Time (60 :% 1) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (60 :% 1)
Time Minute
x
      (forall (unitFrom :: Rat).
KnownDivRat unitFrom Second =>
Time unitFrom -> Time Second
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Second -> Time Second
x) | Time (1 :% 1)
Time Second
x Time (1 :% 1) -> Time (1 :% 1) -> Bool
forall a. Ord a => a -> a -> Bool
> RatioNat -> Time Second
sec 1 -> Time (1 :% 1) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1)
Time Second
x
      (forall (unitFrom :: Rat).
KnownDivRat unitFrom Millisecond =>
Time unitFrom -> Time Millisecond
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Millisecond -> Time Millisecond
x) | Time (1 :% 1000)
Time Millisecond
x Time (1 :% 1000) -> Time (1 :% 1000) -> Bool
forall a. Ord a => a -> a -> Bool
> RatioNat -> Time Millisecond
ms 1 -> Time (1 :% 1000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1000)
Time Millisecond
x
      (forall (unitFrom :: Rat).
KnownDivRat unitFrom Microsecond =>
Time unitFrom -> Time Microsecond
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Microsecond -> Time Microsecond
x) | Time (1 :% 1000000)
Time Microsecond
x Time (1 :% 1000000) -> Time (1 :% 1000000) -> Bool
forall a. Ord a => a -> a -> Bool
> RatioNat -> Time Microsecond
mcs 1 -> Time (1 :% 1000000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1000000)
Time Microsecond
x
      (forall (unitFrom :: Rat).
KnownDivRat unitFrom Nanosecond =>
Time unitFrom -> Time Nanosecond
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Nanosecond -> Time Nanosecond
x) | Time (1 :% 1000000000)
Time Nanosecond
x Time (1 :% 1000000000) -> Time (1 :% 1000000000) -> Bool
forall a. Ord a => a -> a -> Bool
> RatioNat -> Time Nanosecond
ns 1 -> Time (1 :% 1000000000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1000000000)
Time Nanosecond
x
      _ -> Time (1 :% 1000000000000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format (Time (1 :% 1) -> Time Picosecond
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Picosecond Time (1 :% 1)
Time Second
n)

    format :: forall unit. KnownUnitName unit => Time unit -> Text
    format :: Time unit -> Text
format n :: Time unit
n =
      ToText String => String -> Text
forall a. ToText a => a -> Text
toText @String (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Double -> String -> String
forall r. PrintfType r => String -> r
printf "%.4f%s"
        ((Real RatioNat, Fractional Double) => RatioNat -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac @RatioNat @Double (RatioNat -> Double) -> RatioNat -> Double
forall a b. (a -> b) -> a -> b
$ Time unit -> RatioNat
forall (rat :: Rat). Time rat -> RatioNat
unTime Time unit
n)
        (KnownUnitName unit => String
forall (unit :: Rat). KnownUnitName unit => String
unitNameVal @unit)

----------------------------------------------------------------------------
-- Generator
----------------------------------------------------------------------------

-- | Randomly selects one of the two generators.
genEither :: MonadGen m => m a -> m b -> m (Either a b)
genEither :: m a -> m b -> m (Either a b)
genEither genA :: m a
genA genB :: m b
genB = [m (Either a b)] -> m (Either a b)
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice [ a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> m a -> m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
genA, b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> m b -> m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
genB ]

-- | Generates an @a@ and a @b@ and wraps them in a tuple.
genTuple2 :: MonadGen m => m a -> m b -> m (a, b)
genTuple2 :: m a -> m b -> m (a, b)
genTuple2 = (a -> b -> (a, b)) -> m a -> m b -> m (a, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)

-- | Run the given generator deterministically, by fixing its size and seed.
runGen :: HasCallStack => Range.Size -> Word64 -> Gen a -> a
runGen :: Size -> Word64 -> Gen a -> a
runGen size :: Size
size seed :: Word64
seed genT :: Gen a
genT =
  let tree :: TreeT (MaybeT Identity) a
tree = Size -> Seed -> Gen a -> TreeT (MaybeT Identity) a
forall (m :: * -> *) a.
Size -> Seed -> GenT m a -> TreeT (MaybeT m) a
runGenT Size
size (Word64 -> Seed
Seed.from Word64
seed) Gen a
genT
      node :: NodeT (MaybeT Identity) a
node = NodeT (MaybeT Identity) a
-> Maybe (NodeT (MaybeT Identity) a) -> NodeT (MaybeT Identity) a
forall a. a -> Maybe a -> a
fromMaybe NodeT (MaybeT Identity) a
discardedErr (Maybe (NodeT (MaybeT Identity) a) -> NodeT (MaybeT Identity) a)
-> Maybe (NodeT (MaybeT Identity) a) -> NodeT (MaybeT Identity) a
forall a b. (a -> b) -> a -> b
$ Identity (Maybe (NodeT (MaybeT Identity) a))
-> Maybe (NodeT (MaybeT Identity) a)
forall a. Identity a -> a
runIdentity (Identity (Maybe (NodeT (MaybeT Identity) a))
 -> Maybe (NodeT (MaybeT Identity) a))
-> Identity (Maybe (NodeT (MaybeT Identity) a))
-> Maybe (NodeT (MaybeT Identity) a)
forall a b. (a -> b) -> a -> b
$ MaybeT Identity (NodeT (MaybeT Identity) a)
-> Identity (Maybe (NodeT (MaybeT Identity) a))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Identity (NodeT (MaybeT Identity) a)
 -> Identity (Maybe (NodeT (MaybeT Identity) a)))
-> MaybeT Identity (NodeT (MaybeT Identity) a)
-> Identity (Maybe (NodeT (MaybeT Identity) a))
forall a b. (a -> b) -> a -> b
$ TreeT (MaybeT Identity) a
-> MaybeT Identity (NodeT (MaybeT Identity) a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT (MaybeT Identity) a
tree
      discardedErr :: NodeT (MaybeT Identity) a
discardedErr = Text -> NodeT (MaybeT Identity) a
forall a. HasCallStack => Text -> a
error (Text -> NodeT (MaybeT Identity) a)
-> Text -> NodeT (MaybeT Identity) a
forall a b. (a -> b) -> a -> b
$
        "Generator could not produce a value for size "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Size -> Text
forall b a. (Show a, IsString b) => a -> b
show Size
size Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " and seed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall b a. (Show a, IsString b) => a -> b
show Word64
seed
  in  NodeT (MaybeT Identity) a -> a
forall (m :: * -> *) a. NodeT m a -> a
nodeValue NodeT (MaybeT Identity) a
node



----------------------------------------------------------------------------
-- Roundtrip
----------------------------------------------------------------------------

-- | This 'TestTree' contains a property based test for conversion from
-- some @x@ to some @y@ and back to @x@ (it should successfully return
-- the initial @x@).
roundtripTest
  :: forall x y err.
     ( Show x
     , Show err
     , Typeable x
     , Arbitrary x
     , Eq x
     , Eq err
     )
  => (x -> y)
  -> (y -> Either err x)
  -> TestTree
roundtripTest :: (x -> y) -> (y -> Either err x) -> TestTree
roundtripTest xToY :: x -> y
xToY yToX :: y -> Either err x
yToX = String -> (x -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
TQC.testProperty String
typeName x -> Property
check
  where
    typeName :: String
typeName = TypeRep -> String
forall b a. (Show a, IsString b) => a -> b
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy x -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy x
forall k (t :: k). Proxy t
Proxy @x)
    check :: x -> QC.Property
    check :: x -> Property
check x :: x
x = y -> Either err x
yToX (x -> y
xToY x
x) Either err x -> Either err x -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== x -> Either err x
forall a b. b -> Either a b
Right x
x
{-# DEPRECATED roundtripTest "Use 'roundtripTree' instead." #-}

-- | This 'TestTree' contains a property based test for conversion from
-- some @x@ to some @y@ and back to @x@ (it should successfully return
-- the initial @x@).
roundtripTree
  :: forall x y err.
     ( Show x
     , Show y
     , Show err
     , Typeable x
     , Eq x
     , Eq err
     )
  => Gen x
  -> (x -> y)
  -> (y -> Either err x)
  -> TestTree
roundtripTree :: Gen x -> (x -> y) -> (y -> Either err x) -> TestTree
roundtripTree genX :: Gen x
genX xToY :: x -> y
xToY yToX :: y -> Either err x
yToX = String -> Property -> TestTree
testProperty String
typeNameX Property
prop
  where
    typeNameX :: String
typeNameX = TypeRep -> String
forall b a. (Show a, IsString b) => a -> b
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy x -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy x
forall k (t :: k). Proxy t
Proxy @x)
    prop :: Property
    prop :: Property
prop = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
      x
x <- Gen x -> PropertyT IO x
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen x
genX
      x -> (x -> y) -> (y -> Either err x) -> PropertyT IO ()
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 x
x x -> y
xToY y -> Either err x
yToX