{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Imp.Common (
  module X,
  io,

  -- * Expectations

  -- ** Lifted expectations
  assertBool,
  assertFailure,
  assertColorFailure,
  expectationFailure,
  shouldBe,
  shouldSatisfy,
  shouldSatisfyExpr,
  shouldStartWith,
  shouldEndWith,
  shouldContain,
  shouldMatchList,
  shouldReturn,
  shouldNotBe,
  shouldNotSatisfy,
  shouldNotContain,
  shouldNotReturn,
  shouldThrow,

  -- ** Non-standard expectations
  shouldBeExpr,
  shouldBeRight,
  shouldBeLeft,
  shouldBeRightExpr,
  shouldBeLeftExpr,
  shouldContainExpr,
  expectRight,
  expectRightDeep_,
  expectRightDeep,
  expectRightExpr,
  expectRightDeepExpr,
  expectLeft,
  expectLeftDeep_,
  expectLeftExpr,
  expectLeftDeep,
  expectLeftDeepExpr,
  expectJust,
  expectNothingExpr,

  -- * MonadGen
  module QuickCheckT,
  arbitrary,
  -- TODO: add here any other lifted functions from quickcheck

  -- * Random interface
  HasStatefulGen (..),
  HasGenEnv (..),
  HasSubState (..),
  subStateM,
  setSubStateM,
  R.StatefulGen,
  StateGen (..),
  StateGenM (..),
  uniformM,
  uniformRM,
  uniformListM,
  uniformListRM,
  uniformByteStringM,
  uniformShortByteStringM,
)
where

import Control.Monad.IO.Class
import Data.Functor.Const (Const (..))
import Data.Functor.Identity (Identity (..))
import Test.Cardano.Ledger.Binary.TreeDiff (expectExprEqualWithMessage)
import Test.Cardano.Ledger.Common as X hiding (
  arbitrary,
  assertBool,
  assertColorFailure,
  assertFailure,
  choose,
  elements,
  expectLeft,
  expectLeftDeep,
  expectLeftDeepExpr,
  expectLeftDeep_,
  expectLeftExpr,
  expectRight,
  expectRightDeep,
  expectRightDeepExpr,
  expectRightDeep_,
  expectRightExpr,
  expectationFailure,
  frequency,
  growingElements,
  listOf,
  listOf1,
  oneof,
  resize,
  shouldBe,
  shouldBeExpr,
  shouldBeLeft,
  shouldBeLeftExpr,
  shouldBeRight,
  shouldBeRightExpr,
  shouldContain,
  shouldEndWith,
  shouldMatchList,
  shouldNotBe,
  shouldNotContain,
  shouldNotReturn,
  shouldNotSatisfy,
  shouldReturn,
  shouldSatisfy,
  shouldStartWith,
  shouldThrow,
  sized,
  suchThat,
  suchThatMaybe,
  variant,
  vectorOf,
 )
import qualified Test.Cardano.Ledger.Common as H
import Test.QuickCheck.GenT as QuickCheckT
import UnliftIO (MonadUnliftIO (..))
import UnliftIO.Exception (Exception, evaluateDeep)

-- Imports needed for Random interface. Separated from the rest, since they will migrate
-- to `random` at a later point:

import Control.Monad.Reader
import Control.Monad.State
import Data.ByteString (ByteString)
import Data.ByteString.Short (ShortByteString)
import Data.Kind
import Data.List (isInfixOf)
import Foreign.Storable
import qualified System.Random.Stateful as R

instance MonadUnliftIO m => MonadUnliftIO (GenT m) where
  withRunInIO :: forall b. ((forall a. GenT m a -> IO a) -> IO b) -> GenT m b
withRunInIO (forall a. GenT m a -> IO a) -> IO b
inner = forall (m :: * -> *) a. (QCGen -> Int -> m a) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \QCGen
qc Int
sz ->
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> (forall a. GenT m a -> IO a) -> IO b
inner forall a b. (a -> b) -> a -> b
$ \(GenT QCGen -> Int -> m a
f) -> forall a. m a -> IO a
run (QCGen -> Int -> m a
f QCGen
qc Int
sz)

infix 1 `shouldBe`
        , `shouldBeExpr`
        , `shouldSatisfy`
        , `shouldStartWith`
        , `shouldEndWith`
        , `shouldContain`
        , `shouldMatchList`
        , `shouldReturn`
        , `shouldThrow`
        , `shouldNotBe`
        , `shouldNotSatisfy`
        , `shouldNotContain`
        , `shouldNotReturn`
        , `shouldBeRight`
        , `shouldBeRightExpr`
        , `shouldBeLeft`
        , `shouldBeLeftExpr`

-- | Enforce the type of expectation
--
-- Useful with polymorphic expectations that are defined below.
--
-- ===__Example__
--
-- Because `shouldBeExpr` is polymorphic in `m`, compiler will choke with a unification
-- error. This is due to the fact that hspec's `it` expects a polymorphic `Example`.
--
-- > it "MyTest" $ do
-- >   "foo" `shouldBeExpr` "bar"
--
-- However, this is easily solved by `io`:
--
-- > it "MyTest" $ io $ do
-- >   "foo" `shouldBeExpr` "bar"
io :: IO a -> IO a
io :: forall a. IO a -> IO a
io = forall a. a -> a
id

-- | Just like `expectationFailure`, but does not force the return type to unit. Lifted
-- version of `H.assertFailure`
assertFailure :: (HasCallStack, MonadIO m) => String -> m a
assertFailure :: forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => String -> IO a
H.assertFailure

assertColorFailure :: (HasCallStack, MonadIO m) => String -> m a
assertColorFailure :: forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertColorFailure = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => String -> IO a
H.assertColorFailure

-- | Lifted version of `H.assertBool`
assertBool :: (HasCallStack, MonadIO m) => String -> Bool -> m ()
assertBool :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> Bool -> m ()
assertBool String
msg = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> Assertion
H.assertBool String
msg

-- | Lifted version of `expectationFailure`.
expectationFailure :: (HasCallStack, MonadIO m) => String -> m ()
expectationFailure :: forall (m :: * -> *). (HasCallStack, MonadIO m) => String -> m ()
expectationFailure = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Assertion
H.expectationFailure

-- | Lifted version of `H.shouldBe`.
shouldBe :: (HasCallStack, Show a, Eq a, MonadIO m) => a -> a -> m ()
shouldBe :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
shouldBe a
x a
y = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a, Eq a) => a -> a -> Assertion
H.shouldBe a
x a
y

shouldBeExpr :: (HasCallStack, ToExpr a, Eq a, MonadIO m) => a -> a -> m ()
shouldBeExpr :: forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
shouldBeExpr a
expected a
actual = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
(ToExpr a, Eq a, HasCallStack) =>
String -> a -> a -> Assertion
expectExprEqualWithMessage String
"" a
expected a
actual

-- | Lifted version of `H.shouldSatisfy`.
shouldSatisfy :: (HasCallStack, Show a, MonadIO m) => a -> (a -> Bool) -> m ()
shouldSatisfy :: forall a (m :: * -> *).
(HasCallStack, Show a, MonadIO m) =>
a -> (a -> Bool) -> m ()
shouldSatisfy a
x a -> Bool
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Assertion
H.shouldSatisfy a
x a -> Bool
f

shouldSatisfyExpr :: (HasCallStack, MonadIO m, ToExpr a) => a -> (a -> Bool) -> m ()
shouldSatisfyExpr :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, ToExpr a) =>
a -> (a -> Bool) -> m ()
shouldSatisfyExpr a
x a -> Bool
f
  | a -> Bool
f a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"predicate failed on:\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> String
showExpr a
x

-- | Lifted version of `H.shouldStartWith`.
shouldStartWith :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m ()
shouldStartWith :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
[a] -> [a] -> m ()
shouldStartWith [a]
x [a]
y = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> Assertion
H.shouldStartWith [a]
x [a]
y

-- | Lifted version of `H.shouldEndWith`.
shouldEndWith :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m ()
shouldEndWith :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
[a] -> [a] -> m ()
shouldEndWith [a]
x [a]
y = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> Assertion
H.shouldEndWith [a]
x [a]
y

-- | Lifted version of `H.shouldContain`.
shouldContain :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m ()
shouldContain :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
[a] -> [a] -> m ()
shouldContain [a]
x [a]
y = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> Assertion
H.shouldContain [a]
x [a]
y

shouldContainExpr :: (HasCallStack, ToExpr a, Eq a, MonadIO m) => [a] -> [a] -> m ()
shouldContainExpr :: forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
[a] -> [a] -> m ()
shouldContainExpr [a]
x [a]
y
  | [a]
y forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [a]
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise =
      forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$
        String
"First list does not contain the second list:\n"
          forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> String
showExpr [a]
x
          forall a. Semigroup a => a -> a -> a
<> String
"\ndoes not contain\n"
          forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> String
showExpr [a]
y

-- | Lifted version of `H.shouldMatchList`.
shouldMatchList :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m ()
shouldMatchList :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
[a] -> [a] -> m ()
shouldMatchList [a]
x [a]
y = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> Assertion
H.shouldMatchList [a]
x [a]
y

-- | Lifted version of `H.shouldReturn`.
shouldReturn :: (HasCallStack, Show a, Eq a, MonadUnliftIO m) => m a -> a -> m ()
shouldReturn :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadUnliftIO m) =>
m a -> a -> m ()
shouldReturn m a
f a
a = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Assertion
H.shouldReturn (forall a. m a -> IO a
run m a
f) a
a

-- | Lifted version of `H.shouldNotBe`.
shouldNotBe :: (HasCallStack, Show a, Eq a, MonadIO m) => a -> a -> m ()
shouldNotBe :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
shouldNotBe a
x a
y = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a, Eq a) => a -> a -> Assertion
H.shouldNotBe a
x a
y

-- | Lifted version of `H.shouldNotSatisfy`.
shouldNotSatisfy :: (HasCallStack, Show a, MonadIO m) => a -> (a -> Bool) -> m ()
shouldNotSatisfy :: forall a (m :: * -> *).
(HasCallStack, Show a, MonadIO m) =>
a -> (a -> Bool) -> m ()
shouldNotSatisfy a
a a -> Bool
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Assertion
H.shouldNotSatisfy a
a a -> Bool
f

-- | Lifted version of `H.shouldNotContain`.
shouldNotContain :: (HasCallStack, Show a, Eq a, MonadIO m) => [a] -> [a] -> m ()
shouldNotContain :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
[a] -> [a] -> m ()
shouldNotContain [a]
x [a]
y = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> Assertion
H.shouldNotContain [a]
x [a]
y

-- | Lifted version of `H.shouldNotReturn`.
shouldNotReturn :: (HasCallStack, Show a, Eq a, MonadUnliftIO m) => m a -> a -> m ()
shouldNotReturn :: forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadUnliftIO m) =>
m a -> a -> m ()
shouldNotReturn m a
f a
a = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Assertion
H.shouldNotReturn (forall a. m a -> IO a
run m a
f) a
a

-- | Lifted version of `shouldThrow`.
shouldThrow :: (HasCallStack, Exception e, MonadUnliftIO m) => m a -> Selector e -> m ()
shouldThrow :: forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadUnliftIO m) =>
m a -> Selector e -> m ()
shouldThrow m a
f Selector e
s = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Assertion
H.shouldThrow (forall a. m a -> IO a
run m a
f) Selector e
s

-- | Return value on the `Right` and fail otherwise. Lifted version of `H.expectRight`.
expectRight :: (HasCallStack, Show a, MonadIO m) => Either a b -> m b
expectRight :: forall a (m :: * -> *) b.
(HasCallStack, Show a, MonadIO m) =>
Either a b -> m b
expectRight (Right b
r) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! b
r
expectRight (Left a
l) = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Expected Right, got Left:\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
l

-- | Same as `expectRightDeep`, but discards the result
expectRightDeep_ :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m ()
expectRightDeep_ :: forall a b (m :: * -> *).
(HasCallStack, Show a, NFData b, MonadIO m) =>
Either a b -> m ()
expectRightDeep_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b (m :: * -> *).
(HasCallStack, Show a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeep

-- | Same as `expectRight`, but also evaluate the returned value to NF
expectRightDeep :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m b
expectRightDeep :: forall a b (m :: * -> *).
(HasCallStack, Show a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeep = forall a (m :: * -> *) b.
(HasCallStack, Show a, MonadIO m) =>
Either a b -> m b
expectRight forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | Same as `expectRight`, but use `ToExpr` instead of `Show`
expectRightExpr :: (HasCallStack, ToExpr a, MonadIO m) => Either a b -> m b
expectRightExpr :: forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr (Right b
r) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! b
r
expectRightExpr (Left a
l) = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Expected Right, got Left:\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> String
showExpr a
l

-- | Same as `expectRightDeep`,  but use `ToExpr` instead of `Show`
expectRightDeepExpr :: (HasCallStack, ToExpr a, NFData b, MonadIO m) => Either a b -> m b
expectRightDeepExpr :: forall a b (m :: * -> *).
(HasCallStack, ToExpr a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeepExpr = forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | Same as `shouldBe`, except it checks that the value is `Right`
shouldBeRight :: (HasCallStack, Show a, Show b, Eq b, MonadIO m) => Either a b -> b -> m ()
shouldBeRight :: forall a b (m :: * -> *).
(HasCallStack, Show a, Show b, Eq b, MonadIO m) =>
Either a b -> b -> m ()
shouldBeRight Either a b
e b
x = forall a (m :: * -> *) b.
(HasCallStack, Show a, MonadIO m) =>
Either a b -> m b
expectRight Either a b
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` b
x)

-- | Same as `shouldBeExpr`, except it checks that the value is `Right`
shouldBeRightExpr :: (HasCallStack, ToExpr a, Eq b, ToExpr b, MonadIO m) => Either a b -> b -> m ()
shouldBeRightExpr :: forall a b (m :: * -> *).
(HasCallStack, ToExpr a, Eq b, ToExpr b, MonadIO m) =>
Either a b -> b -> m ()
shouldBeRightExpr Either a b
e b
x = forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr Either a b
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` b
x)

-- | Return value on the `Left` and fail otherwise
expectLeft :: (HasCallStack, Show b, MonadIO m) => Either a b -> m a
expectLeft :: forall b (m :: * -> *) a.
(HasCallStack, Show b, MonadIO m) =>
Either a b -> m a
expectLeft (Left a
l) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! a
l
expectLeft (Right b
r) = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Expected Left, got Right:\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show b
r

-- | Same as `expectLeftDeep`, but discards the result
expectLeftDeep_ :: (HasCallStack, MonadIO m, Show b, NFData a) => Either a b -> m ()
expectLeftDeep_ :: forall (m :: * -> *) b a.
(HasCallStack, MonadIO m, Show b, NFData a) =>
Either a b -> m ()
expectLeftDeep_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b (m :: * -> *).
(HasCallStack, NFData a, Show b, MonadIO m) =>
Either a b -> m a
expectLeftDeep

-- | Same as `expectLeft`, but also evaluate the returned value to NF
expectLeftDeep :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m a
expectLeftDeep :: forall a b (m :: * -> *).
(HasCallStack, NFData a, Show b, MonadIO m) =>
Either a b -> m a
expectLeftDeep = forall b (m :: * -> *) a.
(HasCallStack, Show b, MonadIO m) =>
Either a b -> m a
expectLeft forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | Same as `expectLeft`, but use `ToExpr` instead of `Show`
expectLeftExpr :: (HasCallStack, ToExpr b, MonadIO m) => Either a b -> m a
expectLeftExpr :: forall b (m :: * -> *) a.
(HasCallStack, ToExpr b, MonadIO m) =>
Either a b -> m a
expectLeftExpr (Left a
l) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! a
l
expectLeftExpr (Right b
r) = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Expected Left, got Right:\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> String
showExpr b
r

-- | Same as `expectLeftDeep`,  but use `ToExpr` instead of `Show`
expectLeftDeepExpr :: (HasCallStack, ToExpr b, NFData a, MonadIO m) => Either a b -> m a
expectLeftDeepExpr :: forall b a (m :: * -> *).
(HasCallStack, ToExpr b, NFData a, MonadIO m) =>
Either a b -> m a
expectLeftDeepExpr = forall b (m :: * -> *) a.
(HasCallStack, ToExpr b, MonadIO m) =>
Either a b -> m a
expectLeftExpr forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | Same as `shouldBe`, except it checks that the value is `Left`
shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b, MonadIO m) => Either a b -> a -> m ()
shouldBeLeft :: forall a b (m :: * -> *).
(HasCallStack, Show a, Eq a, Show b, MonadIO m) =>
Either a b -> a -> m ()
shouldBeLeft Either a b
e a
x = forall b (m :: * -> *) a.
(HasCallStack, Show b, MonadIO m) =>
Either a b -> m a
expectLeft Either a b
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` a
x)

-- | Same as `shouldBeExpr`, except it checks that the value is `Left`
shouldBeLeftExpr :: (HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) => Either a b -> a -> m ()
shouldBeLeftExpr :: forall a b (m :: * -> *).
(HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) =>
Either a b -> a -> m ()
shouldBeLeftExpr Either a b
e a
x = forall b (m :: * -> *) a.
(HasCallStack, ToExpr b, MonadIO m) =>
Either a b -> m a
expectLeftExpr Either a b
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` a
x)

expectJust :: (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust :: forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust (Just a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
expectJust Maybe a
Nothing = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure String
"Expected Just, got Nothing"

expectNothingExpr :: (HasCallStack, MonadIO m, ToExpr a) => Maybe a -> m ()
expectNothingExpr :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, ToExpr a) =>
Maybe a -> m ()
expectNothingExpr (Just a
x) =
  forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$
    String
"Expected Nothing, got Just:\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> String
showExpr a
x
expectNothingExpr Maybe a
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

---------------------------
-- MonadGen alternatives --
---------------------------

arbitrary :: (Arbitrary a, MonadGen m) => m a
arbitrary :: forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary = forall (g :: * -> *) a. MonadGen g => Gen a -> g a
liftGen forall a. Arbitrary a => Gen a
H.arbitrary

---------------------------------------------------------------------------
-- This interface will be defined in the next major version of `random` ---
---------------------------------------------------------------------------

class R.StatefulGen g m => HasStatefulGen g m | m -> g where
  askStatefulGen :: m g

class HasGenEnv env g | env -> g where
  getGenEnv :: env -> g

instance
  (HasGenEnv env g, R.StatefulGen g (ReaderT env m), Monad m) =>
  HasStatefulGen g (ReaderT env m)
  where
  askStatefulGen :: ReaderT env m g
askStatefulGen = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env g. HasGenEnv env g => env -> g
getGenEnv

class HasSubState s where
  type SubState s :: Type
  getSubState :: s -> SubState s
  getSubState = forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (f :: * -> *).
(HasSubState s, Functor f) =>
(SubState s -> f (SubState s)) -> s -> f s
subStateL forall {k} a (b :: k). a -> Const a b
Const
  setSubState :: s -> SubState s -> s
  setSubState s
s SubState s
a = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall s (f :: * -> *).
(HasSubState s, Functor f) =>
(SubState s -> f (SubState s)) -> s -> f s
subStateL (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity a
Identity SubState s
a) s
s
  subStateL :: Functor f => (SubState s -> f (SubState s)) -> (s -> f s)
  subStateL SubState s -> f (SubState s)
k s
s = forall s. HasSubState s => s -> SubState s -> s
setSubState s
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubState s -> f (SubState s)
k (forall s. HasSubState s => s -> SubState s
getSubState s
s)
  {-# MINIMAL subStateL | getSubState, setSubState #-}

setSubStateM :: (HasSubState s, MonadState s m) => SubState s -> m ()
setSubStateM :: forall s (m :: * -> *).
(HasSubState s, MonadState s m) =>
SubState s -> m ()
setSubStateM SubState s
s = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const ((), SubState s
s)
{-# INLINE setSubStateM #-}

-- | Modify the sub-state and return a value, using the supplied function.
-- Similar to the `state` method of `MonadState`.
subStateM :: (HasSubState s, MonadState s m) => (SubState s -> (a, SubState s)) -> m a
subStateM :: forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM = forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (f :: * -> *).
(HasSubState s, Functor f) =>
(SubState s -> f (SubState s)) -> s -> f s
subStateL -- Uses (a,) as the functor for subStateL
{-# INLINE subStateM #-}

uniformM ::
  ( HasStatefulGen g m
  , R.Uniform a
  ) =>
  m a
uniformM :: forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM = forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
R.uniformM
{-# INLINE uniformM #-}

uniformRM ::
  ( HasStatefulGen g m
  , R.UniformRange a
  ) =>
  (a, a) ->
  m a
uniformRM :: forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (a, a)
r = forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
R.uniformRM (a, a)
r
{-# INLINE uniformRM #-}

uniformListM ::
  ( HasStatefulGen g m
  , R.Uniform a
  ) =>
  Int ->
  m [a]
uniformListM :: forall g (m :: * -> *) a.
(HasStatefulGen g m, Uniform a) =>
Int -> m [a]
uniformListM Int
n = forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall g (m :: * -> *) a.
(StatefulGen g m, Uniform a) =>
Int -> g -> m [a]
R.uniformListM Int
n
{-# INLINE uniformListM #-}

uniformListRM ::
  ( HasStatefulGen g m
  , R.UniformRange a
  ) =>
  (a, a) ->
  Int ->
  m [a]
uniformListRM :: forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> Int -> m [a]
uniformListRM (a, a)
r Int
n = forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
R.uniformRM (a, a)
r
{-# INLINE uniformListRM #-}

uniformByteStringM :: HasStatefulGen a m => Int -> m ByteString
uniformByteStringM :: forall a (m :: * -> *). HasStatefulGen a m => Int -> m ByteString
uniformByteStringM Int
n = forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall g (m :: * -> *). StatefulGen g m => Int -> g -> m ByteString
R.uniformByteStringM Int
n
{-# INLINE uniformByteStringM #-}

uniformShortByteStringM :: HasStatefulGen a m => Int -> m ShortByteString
uniformShortByteStringM :: forall a (m :: * -> *).
HasStatefulGen a m =>
Int -> m ShortByteString
uniformShortByteStringM Int
n = forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall g (m :: * -> *).
StatefulGen g m =>
Int -> g -> m ShortByteString
R.uniformShortByteString Int
n
{-# INLINE uniformShortByteStringM #-}

data StateGenM s = StateGenM

newtype StateGen s = StateGen {forall s. StateGen s -> s
unStateGen :: s}
  deriving (StateGen s -> StateGen s -> Bool
forall s. Eq s => StateGen s -> StateGen s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StateGen s -> StateGen s -> Bool
$c/= :: forall s. Eq s => StateGen s -> StateGen s -> Bool
== :: StateGen s -> StateGen s -> Bool
$c== :: forall s. Eq s => StateGen s -> StateGen s -> Bool
Eq, StateGen s -> StateGen s -> Bool
StateGen s -> StateGen s -> Ordering
StateGen s -> StateGen s -> StateGen s
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s}. Ord s => Eq (StateGen s)
forall s. Ord s => StateGen s -> StateGen s -> Bool
forall s. Ord s => StateGen s -> StateGen s -> Ordering
forall s. Ord s => StateGen s -> StateGen s -> StateGen s
min :: StateGen s -> StateGen s -> StateGen s
$cmin :: forall s. Ord s => StateGen s -> StateGen s -> StateGen s
max :: StateGen s -> StateGen s -> StateGen s
$cmax :: forall s. Ord s => StateGen s -> StateGen s -> StateGen s
>= :: StateGen s -> StateGen s -> Bool
$c>= :: forall s. Ord s => StateGen s -> StateGen s -> Bool
> :: StateGen s -> StateGen s -> Bool
$c> :: forall s. Ord s => StateGen s -> StateGen s -> Bool
<= :: StateGen s -> StateGen s -> Bool
$c<= :: forall s. Ord s => StateGen s -> StateGen s -> Bool
< :: StateGen s -> StateGen s -> Bool
$c< :: forall s. Ord s => StateGen s -> StateGen s -> Bool
compare :: StateGen s -> StateGen s -> Ordering
$ccompare :: forall s. Ord s => StateGen s -> StateGen s -> Ordering
Ord, Int -> StateGen s -> ShowS
forall s. Show s => Int -> StateGen s -> ShowS
forall s. Show s => [StateGen s] -> ShowS
forall s. Show s => StateGen s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StateGen s] -> ShowS
$cshowList :: forall s. Show s => [StateGen s] -> ShowS
show :: StateGen s -> String
$cshow :: forall s. Show s => StateGen s -> String
showsPrec :: Int -> StateGen s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> StateGen s -> ShowS
Show, Int -> StateGen s -> (ShortByteString, StateGen s)
Word32 -> StateGen s -> (Word32, StateGen s)
Word64 -> StateGen s -> (Word64, StateGen s)
StateGen s -> (Int, Int)
StateGen s -> (Int, StateGen s)
StateGen s -> (Word8, StateGen s)
StateGen s -> (Word16, StateGen s)
StateGen s -> (Word32, StateGen s)
StateGen s -> (Word64, StateGen s)
StateGen s -> (StateGen s, StateGen s)
forall s.
RandomGen s =>
Int -> StateGen s -> (ShortByteString, StateGen s)
forall s.
RandomGen s =>
Word32 -> StateGen s -> (Word32, StateGen s)
forall s.
RandomGen s =>
Word64 -> StateGen s -> (Word64, StateGen s)
forall s. RandomGen s => StateGen s -> (Int, Int)
forall s. RandomGen s => StateGen s -> (Int, StateGen s)
forall s. RandomGen s => StateGen s -> (Word8, StateGen s)
forall s. RandomGen s => StateGen s -> (Word16, StateGen s)
forall s. RandomGen s => StateGen s -> (Word32, StateGen s)
forall s. RandomGen s => StateGen s -> (Word64, StateGen s)
forall s. RandomGen s => StateGen s -> (StateGen s, StateGen s)
forall g.
(g -> (Int, g))
-> (g -> (Word8, g))
-> (g -> (Word16, g))
-> (g -> (Word32, g))
-> (g -> (Word64, g))
-> (Word32 -> g -> (Word32, g))
-> (Word64 -> g -> (Word64, g))
-> (Int -> g -> (ShortByteString, g))
-> (g -> (Int, Int))
-> (g -> (g, g))
-> RandomGen g
split :: StateGen s -> (StateGen s, StateGen s)
$csplit :: forall s. RandomGen s => StateGen s -> (StateGen s, StateGen s)
genRange :: StateGen s -> (Int, Int)
$cgenRange :: forall s. RandomGen s => StateGen s -> (Int, Int)
genShortByteString :: Int -> StateGen s -> (ShortByteString, StateGen s)
$cgenShortByteString :: forall s.
RandomGen s =>
Int -> StateGen s -> (ShortByteString, StateGen s)
genWord64R :: Word64 -> StateGen s -> (Word64, StateGen s)
$cgenWord64R :: forall s.
RandomGen s =>
Word64 -> StateGen s -> (Word64, StateGen s)
genWord32R :: Word32 -> StateGen s -> (Word32, StateGen s)
$cgenWord32R :: forall s.
RandomGen s =>
Word32 -> StateGen s -> (Word32, StateGen s)
genWord64 :: StateGen s -> (Word64, StateGen s)
$cgenWord64 :: forall s. RandomGen s => StateGen s -> (Word64, StateGen s)
genWord32 :: StateGen s -> (Word32, StateGen s)
$cgenWord32 :: forall s. RandomGen s => StateGen s -> (Word32, StateGen s)
genWord16 :: StateGen s -> (Word16, StateGen s)
$cgenWord16 :: forall s. RandomGen s => StateGen s -> (Word16, StateGen s)
genWord8 :: StateGen s -> (Word8, StateGen s)
$cgenWord8 :: forall s. RandomGen s => StateGen s -> (Word8, StateGen s)
next :: StateGen s -> (Int, StateGen s)
$cnext :: forall s. RandomGen s => StateGen s -> (Int, StateGen s)
R.RandomGen, Ptr (StateGen s) -> IO (StateGen s)
Ptr (StateGen s) -> Int -> IO (StateGen s)
Ptr (StateGen s) -> Int -> StateGen s -> Assertion
Ptr (StateGen s) -> StateGen s -> Assertion
StateGen s -> Int
forall b. Ptr b -> Int -> IO (StateGen s)
forall b. Ptr b -> Int -> StateGen s -> Assertion
forall s. Storable s => Ptr (StateGen s) -> IO (StateGen s)
forall s. Storable s => Ptr (StateGen s) -> Int -> IO (StateGen s)
forall s.
Storable s =>
Ptr (StateGen s) -> Int -> StateGen s -> Assertion
forall s. Storable s => Ptr (StateGen s) -> StateGen s -> Assertion
forall s. Storable s => StateGen s -> Int
forall s b. Storable s => Ptr b -> Int -> IO (StateGen s)
forall s b. Storable s => Ptr b -> Int -> StateGen s -> Assertion
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> Assertion)
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> Assertion)
-> (Ptr a -> IO a)
-> (Ptr a -> a -> Assertion)
-> Storable a
poke :: Ptr (StateGen s) -> StateGen s -> Assertion
$cpoke :: forall s. Storable s => Ptr (StateGen s) -> StateGen s -> Assertion
peek :: Ptr (StateGen s) -> IO (StateGen s)
$cpeek :: forall s. Storable s => Ptr (StateGen s) -> IO (StateGen s)
pokeByteOff :: forall b. Ptr b -> Int -> StateGen s -> Assertion
$cpokeByteOff :: forall s b. Storable s => Ptr b -> Int -> StateGen s -> Assertion
peekByteOff :: forall b. Ptr b -> Int -> IO (StateGen s)
$cpeekByteOff :: forall s b. Storable s => Ptr b -> Int -> IO (StateGen s)
pokeElemOff :: Ptr (StateGen s) -> Int -> StateGen s -> Assertion
$cpokeElemOff :: forall s.
Storable s =>
Ptr (StateGen s) -> Int -> StateGen s -> Assertion
peekElemOff :: Ptr (StateGen s) -> Int -> IO (StateGen s)
$cpeekElemOff :: forall s. Storable s => Ptr (StateGen s) -> Int -> IO (StateGen s)
alignment :: StateGen s -> Int
$calignment :: forall s. Storable s => StateGen s -> Int
sizeOf :: StateGen s -> Int
$csizeOf :: forall s. Storable s => StateGen s -> Int
Storable, StateGen s -> ()
forall s. NFData s => StateGen s -> ()
forall a. (a -> ()) -> NFData a
rnf :: StateGen s -> ()
$crnf :: forall s. NFData s => StateGen s -> ()
NFData)

instance HasSubState (StateGen g) where
  type SubState (StateGen g) = g
  getSubState :: StateGen g -> SubState (StateGen g)
getSubState (StateGen g
g) = g
g
  {-# INLINE getSubState #-}
  setSubState :: StateGen g -> SubState (StateGen g) -> StateGen g
setSubState StateGen g
_ = forall s. s -> StateGen s
StateGen
  {-# INLINE setSubState #-}

instance
  (HasSubState s, R.RandomGen (SubState s), MonadState s m) =>
  R.StatefulGen (StateGenM s) m
  where
  uniformWord32R :: Word32 -> StateGenM s -> m Word32
uniformWord32R Word32
r StateGenM s
_ = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM (forall g. RandomGen g => Word32 -> g -> (Word32, g)
R.genWord32R Word32
r)
  {-# INLINE uniformWord32R #-}
  uniformWord64R :: Word64 -> StateGenM s -> m Word64
uniformWord64R Word64
r StateGenM s
_ = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM (forall g. RandomGen g => Word64 -> g -> (Word64, g)
R.genWord64R Word64
r)
  {-# INLINE uniformWord64R #-}
  uniformWord8 :: StateGenM s -> m Word8
uniformWord8 StateGenM s
_ = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (Word8, g)
R.genWord8
  {-# INLINE uniformWord8 #-}
  uniformWord16 :: StateGenM s -> m Word16
uniformWord16 StateGenM s
_ = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (Word16, g)
R.genWord16
  {-# INLINE uniformWord16 #-}
  uniformWord32 :: StateGenM s -> m Word32
uniformWord32 StateGenM s
_ = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (Word32, g)
R.genWord32
  {-# INLINE uniformWord32 #-}
  uniformWord64 :: StateGenM s -> m Word64
uniformWord64 StateGenM s
_ = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (Word64, g)
R.genWord64
  {-# INLINE uniformWord64 #-}
  uniformShortByteString :: Int -> StateGenM s -> m ShortByteString
uniformShortByteString Int
n StateGenM s
_ = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM (forall g. RandomGen g => Int -> g -> (ShortByteString, g)
R.genShortByteString Int
n)
  {-# INLINE uniformShortByteString #-}