Util.hs

-- 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 (error . show) id

leftToPrettyPanic :: (Buildable e, HasCallStack) => Either e a -> a
leftToPrettyPanic = either (error . pretty) id

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

-- | A 'QC.Property' that always fails with given message.
failedProp :: Text -> QC.Property
failedProp r = QC.property $ QC.failed { QC.reason = toString r }
{-# DEPRECATED failedProp "Use 'failedtest' instead." #-}

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

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

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

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

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

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

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

-- | 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 = (withFrozenCallStack $ eval $ rnf 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 upperBound run arg =
  withFrozenCallStack $
    checkReport upperBound $ whnf run 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 upperBound run arg =
  withFrozenCallStack $
    checkReport upperBound $ nf run arg

checkReport
  :: (KnownDivRat unit Second, KnownUnitName unit)
  => HasCallStack => Time unit -> Benchmarkable -> Property
checkReport upperBound benchmarkable =
  withTests 1 $ property $
    evalIO runBench >>= \case
      Nothing -> failedTest "Expected benchmark to complete within 120 seconds."
      Just report ->
        let mean = sec . realToFrac @Double @RatioNat . estPoint . anMean $ reportAnalysis report
        in  if mean < toUnit @Second upperBound
              then succeededTest
              else failedTest $
                "Expected mean estimate to be under "
                <> show upperBound
                <> ", but was "
                <> display mean
  where
    runBench = timeout (minute 2) $
      benchmarkWith' (defaultConfig { verbosity = Quiet }) benchmarkable

    display :: Time Second -> Text
    display n = case n of
      (toUnit @Minute -> x) | x > minute 1 -> format x
      (toUnit @Second -> x) | x > sec 1 -> format x
      (toUnit @Millisecond -> x) | x > ms 1 -> format x
      (toUnit @Microsecond -> x) | x > mcs 1 -> format x
      (toUnit @Nanosecond -> x) | x > ns 1 -> format x
      _ -> format (toUnit @Picosecond n)

    format :: forall unit. KnownUnitName unit => Time unit -> Text
    format n =
      toText @String $ printf "%.4f%s"
        (realToFrac @RatioNat @Double $ unTime n)
        (unitNameVal @unit)

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

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

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

-- | Run the given generator deterministically, by fixing its size and seed.
runGen :: HasCallStack => Range.Size -> Word64 -> Gen a -> a
runGen size seed genT =
  let tree = runGenT size (Seed.from seed) genT
      node = fromMaybe discardedErr $ runIdentity $ runMaybeT $ runTreeT tree
      discardedErr = error $
        "Generator could not produce a value for size "
        <> show size <> " and seed " <> show seed
  in  nodeValue 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 xToY yToX = TQC.testProperty typeName check
  where
    typeName = show $ typeRep (Proxy @x)
    check :: x -> QC.Property
    check x = yToX (xToY x) QC.=== Right 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 genX xToY yToX = testProperty typeNameX prop
  where
    typeNameX = show $ typeRep (Proxy @x)
    prop :: Property
    prop = property $ do
      x <- forAll genX
      tripping x xToY yToX