-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# LANGUAGE QuantifiedConstraints #-}

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

module Test.Cleveland.Util
  ( leftToShowPanic
  , (?-)

  -- * Property
  , failedTest
  , succeededTest
  , eitherIsLeft
  , eitherIsRight
  , meanTimeUpperBoundProp
  , meanTimeUpperBoundPropNF

  -- * Generator
  , genTuple2
  , genRandom
  , runGen

  -- * Roundtrip
  , roundtripTree
  , assertGoesBefore
  , goesBefore

  -- * Pretty-printing
  , formatValue
  , formatSomeValue
  , ShowWith(..)
  , Showing(..)

  -- * Time
  , ceilingUnit
  , timeToFixed
  , timeToNominalDiffTime

  -- * Bytes
  , stripOptional0x
  , fromHex
  , parseAddressFromHex

  -- * Traversals
  , mapEach
  , forEach

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

import Debug qualified (show)

import Control.Lens qualified as L
import Control.Monad.Random (MonadRandom, evalRand, mkStdGen)
import Criterion (Benchmarkable, benchmarkWith', nf, whnf)
import Criterion.Main (defaultConfig)
import Criterion.Types (SampleAnalysis(anMean), Verbosity(Quiet), reportAnalysis, verbosity)
import Data.Fixed (Fixed, HasResolution)
import Data.Ratio ((%))
import Data.Singletons (demote)
import Data.Text qualified as T
import Data.Time (NominalDiffTime, secondsToNominalDiffTime)
import Data.Typeable (typeRep)
import Fmt (Buildable, Builder, build, pretty, (+|), (|+))
import Hedgehog
  (Gen, MonadGen, MonadTest, Property, annotate, evalIO, failure, forAll, property, success,
  tripping, withTests)
import Hedgehog.Gen qualified as Gen
import Hedgehog.Internal.Gen (runGenT)
import Hedgehog.Internal.Seed qualified as Seed
import Hedgehog.Internal.Tree (TreeT(runTreeT), nodeValue)
import Hedgehog.Range qualified as Range
import Statistics.Types (Estimate(estPoint))
import Test.HUnit (Assertion, assertFailure)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)
import Test.Tasty.Hedgehog (testProperty)
import Text.Hex (decodeHex)
import Text.Printf (printf)
import Text.Show qualified
import Time
  (KnownDivRat, KnownUnitName, Microsecond, Millisecond, Minute, Nanosecond, Picosecond, Rat,
  RatioNat, Second, Time, mcs, minute, ms, ns, sec, time, timeout, toUnit, unTime, unitNameVal)

import Morley.Michelson.Doc (DocItem, docItemPosition)
import Morley.Michelson.Typed (SingI, SomeConstrainedValue)
import Morley.Michelson.Typed qualified as T
import Morley.Tezos.Address
import Morley.Util.Constrained

import Test.Cleveland.Instances ()

{-
Note [Hedgehog & withFrozenCallStack]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When an Hedgehog test fails, Hedgehog displays the source code for all callstack frames,
and annotates the top-most frame with the error message.

When an assertion helper like `failedTest` fails, the helper itself will be the top-most frame.
This means that, under normal circumstances, Hedgehog would display the error message
next to `failedTest`'s source code, and **not** next to the user's source code.

In order to force Hedgehog to display the error message next to the user's source code,
we use `withFrozenCallStack` to effectively remove the assertion helper from the callstack.

On a side note: the reason why we don't need to use `withFrozenCallStack` in Cleveland's
assertion helpers is because Cleveland only displays the bottom-most callstack
frame (i.e., the user's source code).
See: Note [Cleveland & callstacks] for more information.
-}

leftToShowPanic :: (PrettyShow e, Show e, HasCallStack) => Either e a -> a
leftToShowPanic :: forall e a. (PrettyShow e, Show e, HasCallStack) => 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. (PrettyShow a, Show a, IsString b) => a -> b
show) a -> a
forall a. a -> a
id

-- | Make a tuple with name without extra syntactic noise.
(?-) :: Text -> a -> (Text, a)
?- :: forall a. Text -> a -> (Text, a)
(?-) = (,)
infixr 0 ?-

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

-- | A 'Property' that always fails with given message.
failedTest :: (HasCallStack, MonadTest m) => Text -> m ()
failedTest :: forall (m :: * -> *). (HasCallStack, MonadTest m) => Text -> m ()
failedTest Text
r =
  -- See: Note [Hedgehog & withFrozenCallStack]
  (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 :: forall (m :: * -> *). MonadTest m => 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 :: forall b (m :: * -> *) a.
(Show b, MonadTest m, HasCallStack) =>
Either a b -> m ()
eitherIsLeft = \case
  Left a
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
succeededTest
  Right b
x ->
    -- See: Note [Hedgehog & withFrozenCallStack]
    (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
$ Text
"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
Debug.show b
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | The 'Property' holds on `Right b`.
eitherIsRight :: (Show a, MonadTest m, HasCallStack) => Either a b -> m ()
eitherIsRight :: forall a (m :: * -> *) b.
(Show a, MonadTest m, HasCallStack) =>
Either a b -> m ()
eitherIsRight = \case
  Right b
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
succeededTest
  Left a
x ->
    -- See: Note [Hedgehog & withFrozenCallStack]
    (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
$ Text
"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
Debug.show a
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | 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 :: forall (unit :: Rat) a b.
(KnownDivRat unit Second, KnownUnitName unit, HasCallStack) =>
Time unit -> (a -> b) -> a -> Property
meanTimeUpperBoundProp Time unit
upperBound a -> b
run a
arg =
  -- See: Note [Hedgehog & withFrozenCallStack]
  (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 :: forall (unit :: Rat) b a.
(KnownDivRat unit Second, KnownUnitName unit, HasCallStack,
 NFData b) =>
Time unit -> (a -> b) -> a -> Property
meanTimeUpperBoundPropNF Time unit
upperBound a -> b
run a
arg =
  -- See: Note [Hedgehog & withFrozenCallStack]
  (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 :: forall (unit :: Rat).
(KnownDivRat unit Second, KnownUnitName unit, HasCallStack) =>
Time unit -> Benchmarkable -> Property
checkReport Time unit
upperBound Benchmarkable
benchmarkable =
  TestLimit -> Property -> Property
withTests TestLimit
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
      Maybe Report
Nothing -> Text -> PropertyT IO ()
forall (m :: * -> *). (HasCallStack, MonadTest m) => Text -> m ()
failedTest Text
"Expected benchmark to complete within 120 seconds."
      Just 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
. 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
< 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
$
                Text
"Expected mean estimate to be under "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time unit -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Time unit
upperBound
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 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 RatioNat
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 Time Second
n = case Time Second
n of
      (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 RatioNat
1 -> Time (60 :% 1) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (60 :% 1)
Time Minute
x
      (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 RatioNat
1 -> Time (1 :% 1) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1)
Time Second
x
      (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 RatioNat
1 -> Time (1 :% 1000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1000)
Time Millisecond
x
      (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 RatioNat
1 -> Time (1 :% 1000000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1000000)
Time Microsecond
x
      (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 RatioNat
1 -> Time (1 :% 1000000000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time (1 :% 1000000000)
Time Nanosecond
x
      Time Second
_ -> Time (1 :% 1000000000000) -> Text
forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format (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 :: forall (unit :: Rat). KnownUnitName unit => Time unit -> Text
format Time unit
n =
      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 String
"%.4f%s"
        (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)
        (forall (unit :: Rat). KnownUnitName unit => String
unitNameVal @unit)

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

-- | Generates an @a@ and a @b@ and wraps them in a tuple.
genTuple2 :: MonadGen m => m a -> m b -> m (a, b)
genTuple2 :: forall (m :: * -> *) a b. MonadGen m => 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 (,)

-- | Construct a hedgehog generator from a generator relying on 'MonadRandom'.
--
-- This neither shrinks nor generates values in a reasonable order,
-- use only when such properties are justified for your type.
genRandom :: MonadGen m => (forall n. MonadRandom n => n a) -> m a
genRandom :: forall (m :: * -> *) a.
MonadGen m =>
(forall (n :: * -> *). MonadRandom n => n a) -> m a
genRandom forall (n :: * -> *). MonadRandom n => n a
gen = Rand StdGen a -> StdGen -> a
forall g a. Rand g a -> g -> a
evalRand Rand StdGen a
forall (n :: * -> *). MonadRandom n => n a
gen (StdGen -> a) -> (Int -> StdGen) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StdGen
mkStdGen (Int -> a) -> m Int -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Int -> m Int
forall (m :: * -> *) a. MonadGen m => m a -> m a
Gen.prune m Int
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded

-- | Run the given generator deterministically, by fixing its size and seed.
runGen :: HasCallStack => Range.Size -> Word64 -> Gen a -> a
runGen :: forall a. HasCallStack => Size -> Word64 -> Gen a -> a
runGen Size
size Word64
seed 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
$
        Text
"Generator could not produce a value for size "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Size -> Int
Range.unSize Size
size) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and seed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall b a. (PrettyShow 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@).
roundtripTree
  :: forall x y err.
     ( Show x
     , Show y
     , Show err
     , Typeable x
     , Eq x
     , Eq err
     , HasCallStack
     )
  => Gen x
  -> (x -> y)
  -> (y -> Either err x)
  -> TestTree
roundtripTree :: forall x y err.
(Show x, Show y, Show err, Typeable x, Eq x, Eq err,
 HasCallStack) =>
Gen x -> (x -> y) -> (y -> Either err x) -> TestTree
roundtripTree Gen x
genX x -> y
xToY y -> Either err x
yToX = String -> Property -> TestTree
testProperty String
typeNameX Property
prop
  where
    typeNameX :: String
typeNameX = TypeRep -> String
forall b a. (PrettyShow 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 (forall {t}. Proxy t
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

-- | Test that one doc item goes before another doc item in generated
-- documentation.
assertGoesBefore
  :: forall d1 d2.
      (DocItem d1, DocItem d2)
  => Proxy d1 -> Proxy d2 -> Assertion
assertGoesBefore :: forall d1 d2.
(DocItem d1, DocItem d2) =>
Proxy d1 -> Proxy d2 -> Assertion
assertGoesBefore Proxy d1
dp1 Proxy d2
dp2 =
  Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DocItemPos
p1 DocItemPos -> DocItemPos -> Bool
forall a. Ord a => a -> a -> Bool
< DocItemPos
p2) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
    String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$
      String
"Doc item " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Proxy d1 -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy d1
dp1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" with position " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DocItemPos -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty DocItemPos
p1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" \
      \goes before doc item " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Proxy d2 -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy d2
dp2) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" with position " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DocItemPos -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty DocItemPos
p2
  where
    p1 :: DocItemPos
p1 = forall d. DocItem d => DocItemPos
docItemPosition @d1
    p2 :: DocItemPos
p2 = forall d. DocItem d => DocItemPos
docItemPosition @d2

-- | Test that one doc item goes before another doc item in generated
-- documentation.
goesBefore
  :: forall d1 d2.
      (DocItem d1, DocItem d2)
  => Proxy d1 -> Proxy d2 -> TestTree
goesBefore :: forall d1 d2.
(DocItem d1, DocItem d2) =>
Proxy d1 -> Proxy d2 -> TestTree
goesBefore Proxy d1
dp1 Proxy d2
dp2 = String -> Assertion -> TestTree
testCase String
testName (Proxy d1 -> Proxy d2 -> Assertion
forall d1 d2.
(DocItem d1, DocItem d2) =>
Proxy d1 -> Proxy d2 -> Assertion
assertGoesBefore Proxy d1
dp1 Proxy d2
dp2)
  where
  testName :: String
testName = Builder
"`" Builder -> Builder -> String
forall b. FromBuilder b => Builder -> Builder -> b
+| forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show @Text (Proxy d1 -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy d1
dp1) Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"` should come before `"
    Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show @Text (Proxy d2 -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy d2
dp2) Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"`"

----------------------------------------------------------------------------
-- Pretty-printing
----------------------------------------------------------------------------

formatValue :: forall t. SingI t => T.Value t -> Builder
formatValue :: forall (t :: T). SingI t => Value t -> Builder
formatValue Value t
v = Builder
"" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Value t -> Builder
forall p. Buildable p => p -> Builder
build Value t
v Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" of type " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: T). (SingKind T, SingI a) => Demote T
demote @t T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""

formatSomeValue :: (forall t. c t => SingI t) => SomeConstrainedValue c -> Builder
formatSomeValue :: forall (c :: T -> Constraint).
(forall (t :: T). c t => SingI t) =>
SomeConstrainedValue c -> Builder
formatSomeValue = (forall (t :: T). c t => Value t -> Builder)
-> Constrained c Value -> Builder
forall {k} (c :: k -> Constraint) (f :: k -> *) r.
(forall (t :: k). c t => f t -> r) -> Constrained c f -> r
foldConstrained forall (t :: T). c t => Value t -> Builder
forall (t :: T). SingI t => Value t -> Builder
formatValue

-- | Derive a 'Show' instance for a type using a custom "show" function.
-- Note: the `show`n value is paren-wrapped iff it's a subexpression,
-- just as an ordinary `Show` would do.
data ShowWith a = ShowWith (a -> String) a

instance Eq a => Eq (ShowWith a) where
  ShowWith a -> String
_ a
x == :: ShowWith a -> ShowWith a -> Bool
== ShowWith a -> String
_ a
y = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y

instance Show (ShowWith a) where
  showsPrec :: Int -> ShowWith a -> String -> String
showsPrec Int
d (ShowWith a -> String
f a
a) = Bool -> (String -> String) -> String -> String
Text.Show.showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
app_prec) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
Text.Show.showString (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ a -> String
f a
a
    where
      app_prec :: Int
app_prec = Int
10

-- | Derive a 'Buildable' instance for a type using 'show'.
newtype Showing a = Showing a
  deriving stock Showing a -> Showing a -> Bool
(Showing a -> Showing a -> Bool)
-> (Showing a -> Showing a -> Bool) -> Eq (Showing a)
forall a. Eq a => Showing a -> Showing a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Showing a -> Showing a -> Bool
$c/= :: forall a. Eq a => Showing a -> Showing a -> Bool
== :: Showing a -> Showing a -> Bool
$c== :: forall a. Eq a => Showing a -> Showing a -> Bool
Eq
  deriving newtype Int -> Showing a -> String -> String
[Showing a] -> String -> String
Showing a -> String
(Int -> Showing a -> String -> String)
-> (Showing a -> String)
-> ([Showing a] -> String -> String)
-> Show (Showing a)
forall a. Show a => Int -> Showing a -> String -> String
forall a. Show a => [Showing a] -> String -> String
forall a. Show a => Showing a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Showing a] -> String -> String
$cshowList :: forall a. Show a => [Showing a] -> String -> String
show :: Showing a -> String
$cshow :: forall a. Show a => Showing a -> String
showsPrec :: Int -> Showing a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Showing a -> String -> String
Show

instance Show a => Buildable (Showing a) where
  build :: Showing a -> Builder
build (Showing a
a) = Text -> Builder
forall p. Buildable p => p -> Builder
build (forall b a. (Show a, IsString b) => a -> b
Debug.show @Text a
a)

----------------------------------------------------------------------------
-- Time
----------------------------------------------------------------------------

-- | Round the given time to the nearest whole number of the given unit,
-- not smaller than the given time.
--
-- @
-- ceilingUnit (sec 2.0) == sec 2
-- ceilingUnit (sec 2.1) == sec 3
-- ceilingUnit (sec 2.9) == sec 3
-- @
ceilingUnit :: forall (unit :: Rat) . Time unit -> Time unit
ceilingUnit :: forall (unit :: Rat). Time unit -> Time unit
ceilingUnit = RatioNat -> Time unit
forall (unit :: Rat). RatioNat -> Time unit
time (RatioNat -> Time unit)
-> (Time unit -> RatioNat) -> Time unit -> Time unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Natural -> RatioNat
forall a. Integral a => a -> a -> Ratio a
% Natural
1) (Natural -> RatioNat)
-> (Time unit -> Natural) -> Time unit -> RatioNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RatioNat -> Natural
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (RatioNat -> Natural)
-> (Time unit -> RatioNat) -> Time unit -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time unit -> RatioNat
forall (rat :: Rat). Time rat -> RatioNat
unTime

-- | Converts the given time to a number with fixed-precision (in the given time unit).
--
-- @
-- timeToFixed (sec 1.234) == (1.2            :: Deci)
-- timeToFixed (sec 1.234) == (1.234          :: Milli)
-- timeToFixed (sec 1.234) == (1.234000000000 :: Pico)
-- @
timeToFixed
  :: forall precision unit
   . HasResolution precision
  => Time unit -> Fixed precision
timeToFixed :: forall {k} (precision :: k) (unit :: Rat).
HasResolution precision =>
Time unit -> Fixed precision
timeToFixed = forall a. Fractional a => Rational -> a
fromRational @(Fixed precision) (Rational -> Fixed precision)
-> (Time unit -> Rational) -> Time unit -> Fixed precision
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RatioNat -> Rational
forall a. Real a => a -> Rational
toRational (RatioNat -> Rational)
-> (Time unit -> RatioNat) -> Time unit -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time unit -> RatioNat
forall (rat :: Rat). Time rat -> RatioNat
unTime

-- | Converts the given time to a 'NominalDiffTime'.
timeToNominalDiffTime :: KnownDivRat unit Second => Time unit -> NominalDiffTime
timeToNominalDiffTime :: forall (unit :: Rat).
KnownDivRat unit Second =>
Time unit -> NominalDiffTime
timeToNominalDiffTime =
  Pico -> NominalDiffTime
secondsToNominalDiffTime (Pico -> NominalDiffTime)
-> (Time unit -> Pico) -> Time unit -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time (1 :% 1) -> Pico
forall {k} (precision :: k) (unit :: Rat).
HasResolution precision =>
Time unit -> Fixed precision
timeToFixed (Time (1 :% 1) -> Pico)
-> (Time unit -> Time (1 :% 1)) -> Time unit -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Second

----------------------------------------------------------------------------
-- Bytes
----------------------------------------------------------------------------

stripOptional0x :: Text -> Text
stripOptional0x :: Text -> Text
stripOptional0x Text
h = Text -> Text -> Maybe Text
T.stripPrefix Text
"0x" Text
h Maybe Text -> Text -> Text
forall a. Maybe a -> a -> a
?: Text
h

fromHex :: Text -> Either Text ByteString
fromHex :: Text -> Either Text ByteString
fromHex Text
hexText =
  let errMsg :: a -> a
errMsg a
hex = a
"Invalid hex: \"" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
hex a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\""
  in Text -> Maybe ByteString -> Either Text ByteString
forall l r. l -> Maybe r -> Either l r
maybeToRight (Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
errMsg Text
hexText) (Maybe ByteString -> Either Text ByteString)
-> (Text -> Maybe ByteString) -> Text -> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex (Text -> Maybe ByteString)
-> (Text -> Text) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripOptional0x (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ Text
hexText

parseAddressFromHex :: Text -> Either Text Address
parseAddressFromHex :: Text -> Either Text Address
parseAddressFromHex = Text -> Either Text ByteString
fromHex (Text -> Either Text ByteString)
-> (ByteString -> Either Text Address)
-> Text
-> Either Text Address
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ParseAddressRawError -> Text)
-> Either ParseAddressRawError Address -> Either Text Address
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseAddressRawError -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Either ParseAddressRawError Address -> Either Text Address)
-> (ByteString -> Either ParseAddressRawError Address)
-> ByteString
-> Either Text Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseAddressRawError Address
parseAddressRaw

----------------------------------------------------------------------------
-- Traversals
----------------------------------------------------------------------------

{- | Version of 'mapM' generalized with 'L.each'.

Example:

> (addr1, addr2, addr3) <- mapEach newAddress ("test1", "test2", "test3")

This is more type-safe than simple 'mapM' since lists do not remember
their length in types.
-}
mapEach
  :: (L.Each s t a b, Applicative m)
  => (a -> m b) -> s -> m t
mapEach :: forall s t a b (m :: * -> *).
(Each s t a b, Applicative m) =>
(a -> m b) -> s -> m t
mapEach = LensLike m s t a b -> LensLike m s t a b
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
L.traverseOf LensLike m s t a b
forall s t a b. Each s t a b => Traversal s t a b
L.each

-- | Version of 'mapEach' with arguments flipped.
forEach
  :: (L.Each s t a b, Applicative m)
  => s -> (a -> m b) -> m t
forEach :: forall s t a b (m :: * -> *).
(Each s t a b, Applicative m) =>
s -> (a -> m b) -> m t
forEach = LensLike m s t a b -> s -> (a -> m b) -> m t
forall (f :: * -> *) s t a b.
LensLike f s t a b -> s -> (a -> f b) -> f t
L.forOf LensLike m s t a b
forall s t a b. Each s t a b => Traversal s t a b
L.each