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

module Test.Cardano.Ledger.Imp.Common (
  -- * Ledger
  KeyPair (..),
  mkAddr,
  mkCredential,

  -- * Re-exports
  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 (..),
  R.StatefulGen,
  uniformM,
  uniformRM,
  uniformListM,
  uniformListRM,
  uniformByteStringM,
  uniformShortByteStringM,

  -- * Re-exports from ImpSpec
  withImpInit,
  modifyImpInit,
) where

import Control.Monad.IO.Class
import Data.List (isInfixOf)
import qualified System.Random.Stateful as R
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 Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr, mkCredential)
import Test.ImpSpec (modifyImpInit, withImpInit)
import Test.ImpSpec.Expectations.Lifted
import Test.ImpSpec.Random (
  HasStatefulGen (..),
  arbitrary,
  uniformByteStringM,
  uniformListM,
  uniformListRM,
  uniformM,
  uniformRM,
  uniformShortByteStringM,
 )
import Test.QuickCheck.GenT as QuickCheckT
import UnliftIO (MonadUnliftIO (..))
import UnliftIO.Exception (evaluateDeep)

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 = (QCGen -> Int -> m b) -> GenT m b
forall (m :: * -> *) a. (QCGen -> Int -> m a) -> GenT m a
GenT ((QCGen -> Int -> m b) -> GenT m b)
-> (QCGen -> Int -> m b) -> GenT m b
forall a b. (a -> b) -> a -> b
$ \QCGen
qc Int
sz ->
    ((forall a. m a -> IO a) -> IO b) -> m b
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
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. GenT m a -> IO a) -> IO b)
-> (forall a. GenT m a -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ \(GenT QCGen -> Int -> m a
f) -> m a -> IO a
forall a. m a -> IO a
run (QCGen -> Int -> m a
f QCGen
qc Int
sz)

infix 1 `shouldBeExpr`
        , `shouldBeRightExpr`
        , `shouldBeLeftExpr`

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 = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> a -> a -> IO ()
forall a.
(ToExpr a, Eq a, HasCallStack) =>
String -> a -> a -> IO ()
expectExprEqualWithMessage String
"" a
expected a
actual

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

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

-- | 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) = b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$! b
r
expectRightExpr (Left a
l) = String -> m b
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> m b) -> String -> m b
forall a b. (a -> b) -> a -> b
$ String
"Expected Right, got Left:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
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 = Either a b -> m b
forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr (Either a b -> m b) -> (b -> m b) -> Either a b -> m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> m b
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | 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 = Either a b -> m b
forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr Either a b
e m b -> (b -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> b -> m ()
forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` b
x)

-- | 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) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$! a
l
expectLeftExpr (Right b
r) = String -> m a
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Expected Left, got Right:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> b -> String
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 = Either a b -> m a
forall b (m :: * -> *) a.
(HasCallStack, ToExpr b, MonadIO m) =>
Either a b -> m a
expectLeftExpr (Either a b -> m a) -> (a -> m a) -> Either a b -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> m a
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | 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 = Either a b -> m a
forall b (m :: * -> *) a.
(HasCallStack, ToExpr b, MonadIO m) =>
Either a b -> m a
expectLeftExpr Either a b
e m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> m ()
forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` a
x)

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