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

{-# OPTIONS_HADDOCK not-home #-}

-- | Various test assertions in the 'MonadCleveland' context.
module Test.Cleveland.Internal.Actions.Assertions
  ( module Test.Cleveland.Internal.Actions.Assertions
  ) where

import Fmt (Buildable, Doc, build, pretty, unlinesF)

import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.Helpers

{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}

-- | Fails the test with the given error message.
failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Doc -> m a
failure :: forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Doc -> m a
failure Doc
msg = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps a)
-> ReaderT caps (ClevelandBaseMonad caps) a
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall a. HasCallStack => Doc -> ClevelandBaseMonad caps a
forall (m :: * -> *).
ClevelandMiscImpl m -> forall a. HasCallStack => Doc -> m a
cmiFailure ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Doc
msg

-- | Fails the test with the given error message if the given condition is false.
assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Doc -> m ()
assert :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Doc -> m ()
assert Bool
b Doc
errMsg =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Doc -> m ()
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Doc -> m a
failure Doc
errMsg

-- | @x \@== expected@ fails the test if @x@ is not equal to @expected@.
(@==)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => a -- ^ The actual value.
  -> a -- ^ The expected value.
  -> m ()
a
actual @== :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@== a
expected =
  Bool -> Doc -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Doc -> m ()
assert (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected) (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Doc
unlinesF
      [ Doc
"Failed comparison"
      , Doc
"━━ Expected (rhs) ━━"
      , a -> Doc
forall a. Buildable a => a -> Doc
build a
expected
      , Doc
"━━ Got (lhs) ━━"
      , a -> Doc
forall a. Buildable a => a -> Doc
build a
actual
      ]
infix 1 @==

-- | Fails the test if the two given values are equal.
(@/=)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => a -> a -> m ()
a
a @/= :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@/= a
b =
  Bool -> Doc -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Doc -> m ()
assert (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b) (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Doc
unlinesF
      [ Doc
"The two values are equal:"
      , a -> Doc
forall a. Buildable a => a -> Doc
build a
a
      ]
infix 1 @/=

-- | Monadic version of '@=='.
--
-- > getBalance addr @@== 10
(@@==)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => m a -- ^ The actual value.
  -> a -- ^ The expected value.
  -> m ()
m a
getActual @@== :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
m a -> a -> m ()
@@== a
expected = do
  a
actual <- m a
getActual
  a
actual a -> a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@== a
expected
infix 1 @@==

-- | Monadic version of '@/='.
--
-- > getBalance addr @@/= 10
(@@/=)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => m a -> a -> m ()
m a
getA @@/= :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
m a -> a -> m ()
@@/= a
b =  do
  a
a <- m a
getA
  a
a a -> a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@/= a
b
infix 1 @@/=

-- | Fails the test if the comparison operator fails when applied to the given arguments.
-- Prints an error message with both arguments.
--
-- Example:
--
-- > checkCompares 2 (>) 1
checkCompares
  :: forall a b caps m
   . (HasCallStack, MonadCleveland caps m, Buildable a, Buildable b)
  => a
  -> (a -> b -> Bool)
  -> b
  -> m ()
checkCompares :: forall a b caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, Buildable a, Buildable b) =>
a -> (a -> b -> Bool) -> b -> m ()
checkCompares a
a a -> b -> Bool
f b
b = (a -> Text) -> a -> (a -> b -> Bool) -> (b -> Text) -> b -> m ()
forall a b caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
(a -> Text) -> a -> (a -> b -> Bool) -> (b -> Text) -> b -> m ()
checkComparesWith a -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty a
a a -> b -> Bool
f b -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty b
b

-- | Like 'checkCompares', but with an explicit show function.
-- This function does not have any constraint on the type parameters @a@ and @b@.
--
-- For example, to print with 'Fmt.pretty':
--
-- > checkComparesWith pretty a (<) pretty b
checkComparesWith
  :: forall a b caps m
   . (HasCallStack, MonadCleveland caps m)
  => (a -> Text)
  -> a
  -> (a -> b -> Bool)
  -> (b -> Text)
  -> b
  -> m ()
checkComparesWith :: forall a b caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
(a -> Text) -> a -> (a -> b -> Bool) -> (b -> Text) -> b -> m ()
checkComparesWith a -> Text
showA a
a a -> b -> Bool
f b -> Text
showB b
b =
  Bool -> Doc -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Doc -> m ()
assert (a -> b -> Bool
f a
a b
b) (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
    [Text] -> Doc
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Doc
unlinesF
      [ Text
"Failed"
      , Text
"━━ lhs ━━"
      , a -> Text
showA a
a
      , Text
"━━ rhs ━━"
      , b -> Text
showB b
b
      ]

-- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`.
evalJust :: (HasCallStack, MonadCleveland caps m) => Doc -> Maybe a -> m a
evalJust :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
Doc -> Maybe a -> m a
evalJust Doc
err = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Doc -> m a
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Doc -> m a
failure Doc
err) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`.
evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Doc) -> Either a b -> m b
evalRight :: forall caps (m :: * -> *) a b.
(HasCallStack, MonadCleveland caps m) =>
(a -> Doc) -> Either a b -> m b
evalRight a -> Doc
mkErr = (a -> m b) -> (b -> m b) -> Either a b -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Doc -> m b
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Doc -> m a
failure (Doc -> m b) -> (a -> Doc) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
mkErr) b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure