{-# LANGUAGE ImplicitParams #-}

module Test.ImpSpec.Expectations (
  -- * Expectations

  -- ** Common
  assertBool,
  assertFailure,
  expectationFailure,
  shouldBe,
  shouldSatisfy,
  shouldStartWith,
  shouldEndWith,
  shouldContain,
  shouldMatchList,
  shouldReturn,
  shouldNotBe,
  shouldNotSatisfy,
  shouldNotContain,
  shouldNotReturn,
  shouldThrow,
  Selector,

  -- ** Custom
  assertColorFailure,

  -- *** Either
  shouldBeRight,
  shouldBeLeft,
  expectRight,
  expectRightDeep,
  expectRightDeep_,
  expectLeft,
  expectLeftDeep,
  expectLeftDeep_,

  -- *** Maybe
  shouldBeJust,
  expectJust,
  expectJustDeep,
  expectJustDeep_,
  expectNothing,

  -- * CallStack helpers
  callStackToLocation,
  srcLocToLocation,
) where

import Control.DeepSeq (NFData)
import Control.Monad (void, (>=>))
import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack)
import Test.HUnit.Base (assertBool, assertFailure)
import Test.Hspec (
  Expectation,
  Selector,
  expectationFailure,
  shouldBe,
  shouldContain,
  shouldEndWith,
  shouldMatchList,
  shouldNotBe,
  shouldNotContain,
  shouldNotReturn,
  shouldNotSatisfy,
  shouldReturn,
  shouldSatisfy,
  shouldStartWith,
  shouldThrow,
 )
import Test.Hspec.Core.Spec (FailureReason (ColorizedReason), Location (..), ResultStatus (Failure))
import UnliftIO.Exception (evaluateDeep, throwIO)

infix 1 `shouldBeRight`
        , `shouldBeLeft`

-- | Similar to `assertFailure`, except hspec will not interfer with any escape sequences
-- that indicate color output.
assertColorFailure :: HasCallStack => String -> IO a
assertColorFailure :: forall a. HasCallStack => String -> IO a
assertColorFailure String
msg =
  ResultStatus -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ResultStatus -> IO a) -> ResultStatus -> IO a
forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure (CallStack -> Maybe Location
callStackToLocation HasCallStack
CallStack
?callStack) (String -> FailureReason
ColorizedReason String
msg)

-- | Return value on the `Right` and fail otherwise.
--
-- Difference from @`shouldSatisfy` action `Data.Either.isRight`@ in that `expectRight`
-- will force the content of the `Right` to WHNF and return it. This expectation will also
-- show the content of the `Left` when expectation fails.
expectRight :: (HasCallStack, Show a) => Either a b -> IO b
expectRight :: forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight (Right b
r) = b -> IO b
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$! b
r
expectRight (Left a
l) = String -> IO b
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO b) -> String -> IO b
forall a b. (a -> b) -> a -> b
$ String
"Expected Right, got Left:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
l

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

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

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

-- | Return value on the `Left` an fail otherwise
--
-- Difference from @`shouldSatisfy` action `Data.Either.isLeft`@ in that `expectLeft` will
-- force the content of the `Left` to WHNF and and return it. This expectation will also
-- show the content of the `Right` when expectation fails.
expectLeft :: (HasCallStack, Show b) => Either a b -> IO a
expectLeft :: forall b a. (HasCallStack, Show b) => Either a b -> IO a
expectLeft (Left a
l) = a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! a
l
expectLeft (Right b
r) = String -> IO a
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Expected Left, got Right:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show b
r

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

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

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

-- | Same as `shouldBe`, except it checks that the value is `Just`
shouldBeJust :: (HasCallStack, Show a, Eq a) => Maybe a -> a -> Expectation
shouldBeJust :: forall a. (HasCallStack, Show a, Eq a) => Maybe a -> a -> IO ()
shouldBeJust Maybe a
e a
x = Maybe a -> IO a
forall a. HasCallStack => Maybe a -> IO a
expectJust Maybe a
e IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` a
x)

-- | Return value from the `Just` an fail otherwise
--
-- Difference from @`shouldSatisfy` action `isJust`@ in that `expectJust` will force the
-- content of the `Just` to WHNF and it will also return it.
expectJust :: HasCallStack => Maybe a -> IO a
expectJust :: forall a. HasCallStack => Maybe a -> IO a
expectJust (Just a
x) = a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! a
x
expectJust Maybe a
Nothing = String -> IO a
forall a. HasCallStack => String -> IO a
assertFailure String
"Expected Just, got Nothing"

-- | Same as `expectJust`, but will force the value to NF
expectJustDeep :: (HasCallStack, NFData a) => Maybe a -> IO a
expectJustDeep :: forall a. (HasCallStack, NFData a) => Maybe a -> IO a
expectJustDeep = Maybe a -> IO a
forall a. HasCallStack => Maybe a -> IO a
expectJust (Maybe a -> IO a) -> (a -> IO a) -> Maybe a -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> IO a
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | Same as `expectJustDeep`, but will discard the forced contents of `Just`
expectJustDeep_ :: (HasCallStack, NFData a) => Maybe a -> IO ()
expectJustDeep_ :: forall a. (HasCallStack, NFData a) => Maybe a -> IO ()
expectJustDeep_ = IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> (Maybe a -> IO a) -> Maybe a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> IO a
forall a. (HasCallStack, NFData a) => Maybe a -> IO a
expectJustDeep

-- | Same as @`shouldSatisfy` action `Data.Maybe.isNothing`@
expectNothing :: (HasCallStack, Show a) => Maybe a -> IO ()
expectNothing :: forall a. (HasCallStack, Show a) => Maybe a -> IO ()
expectNothing (Just a
x) = String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Nothing, got Just: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
expectNothing Maybe a
Nothing = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Convert the top call from the `CallStack` to hspec's `Location`
callStackToLocation :: CallStack -> Maybe Location
callStackToLocation :: CallStack -> Maybe Location
callStackToLocation CallStack
cs =
  case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
    [] -> Maybe Location
forall a. Maybe a
Nothing
    (String
_, SrcLoc
loc) : [(String, SrcLoc)]
_ -> Location -> Maybe Location
forall a. a -> Maybe a
Just (Location -> Maybe Location) -> Location -> Maybe Location
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Location
srcLocToLocation SrcLoc
loc

-- | Convert `SrcLoc` to hspec's `Location`
srcLocToLocation :: SrcLoc -> Location
srcLocToLocation :: SrcLoc -> Location
srcLocToLocation SrcLoc
loc =
  Location
    { locationFile :: String
locationFile = SrcLoc -> String
srcLocFile SrcLoc
loc
    , locationLine :: Int
locationLine = SrcLoc -> Int
srcLocStartLine SrcLoc
loc
    , locationColumn :: Int
locationColumn = SrcLoc -> Int
srcLocStartCol SrcLoc
loc
    }