Assertions.hs

-- 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 msg = do
  withCap getMiscCap \cap -> cmiFailure cap msg

-- | Fails the test with the given error message if the given condition is false.
assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Doc -> m ()
assert b errMsg =
  unless b $ failure 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 ()
actual @== expected =
  assert (actual == expected) $
    unlinesF
      [ "Failed comparison"
      , "━━ Expected (rhs) ━━"
      , build expected
      , "━━ Got (lhs) ━━"
      , build 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 @/= b =
  assert (a /= b) $
    unlinesF
      [ "The two values are equal:"
      , build 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 ()
getActual @@== expected = do
  actual <- getActual
  actual @== expected
infix 1 @@==

-- | Monadic version of '@/='.
--
-- > getBalance addr @@/= 10
(@@/=)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => m a -> a -> m ()
getA @@/= b =  do
  a <- getA
  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 a f b = checkComparesWith pretty a f pretty 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 showA a f showB b =
  assert (f a b) $
    unlinesF
      [ "Failed"
      , "━━ lhs ━━"
      , showA a
      , "━━ rhs ━━"
      , showB 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 err = maybe (failure err) 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 mkErr = either (failure . mkErr) pure