{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Functions for making assertions about test behavior.

module Test.Sandwich.Expectations where

import Control.Exception.Safe
import Control.Monad.IO.Class
import qualified Data.List as L
import Data.String.Interpolate
import qualified Data.Text as T
import GHC.Stack
import Test.Sandwich.Types.Spec

-- * Manually fail a test or mark as pending

-- | General-purpose function to throw a test exception with a 'String'.
expectationFailure :: (HasCallStack, MonadThrow m) => String -> m a
expectationFailure :: String -> m a
expectationFailure = FailureReason -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailureReason -> m a)
-> (String -> FailureReason) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CallStack -> String -> FailureReason
Reason (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack)

-- | Throws a 'Pending' exception, which will cause the test to be marked as pending.
pending :: (HasCallStack, MonadThrow m) => m ()
pending :: m ()
pending = FailureReason -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailureReason -> m ()) -> FailureReason -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> Maybe String -> FailureReason
Pending (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) Maybe String
forall a. Maybe a
Nothing

-- | Throws a 'Pending' exception with a message to add additional details.
pendingWith :: (HasCallStack, MonadThrow m) => String -> m ()
pendingWith :: String -> m ()
pendingWith String
msg = FailureReason -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailureReason -> m ()) -> FailureReason -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> Maybe String -> FailureReason
Pending (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) (String -> Maybe String
forall a. a -> Maybe a
Just String
msg)

-- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.
xit :: (HasCallStack, Monad m, MonadThrow m) => String -> ExampleT context m1 () -> SpecFree context m ()
xit :: String -> ExampleT context m1 () -> SpecFree context m ()
xit String
name ExampleT context m1 ()
_ex = String -> ExampleT context m () -> SpecFree context m ()
forall context (m :: * -> *).
HasCallStack =>
String -> ExampleT context m () -> Free (SpecCommand context m) ()
it String
name (FailureReason -> ExampleT context m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailureReason -> ExampleT context m ())
-> FailureReason -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> Maybe String -> FailureReason
Pending (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) Maybe String
forall a. Maybe a
Nothing)

-- * Expecting failures

-- | Assert that a given action should fail with some 'FailureReason'.
shouldFail :: (HasCallStack, MonadCatch m, MonadThrow m) => m () -> m ()
shouldFail :: m () -> m ()
shouldFail m ()
action = do
  m () -> m (Either FailureReason ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m ()
action m (Either FailureReason ())
-> (Either FailureReason () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (FailureReason
_ :: FailureReason) -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Right () -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected test to fail|]

-- | Assert that a given action should fail with some 'FailureReason' matching a predicate.
shouldFailPredicate :: (HasCallStack, MonadCatch m, MonadThrow m) => (FailureReason -> Bool) -> m () -> m ()
shouldFailPredicate :: (FailureReason -> Bool) -> m () -> m ()
shouldFailPredicate FailureReason -> Bool
pred m ()
action = do
  m () -> m (Either FailureReason ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m ()
action m (Either FailureReason ())
-> (Either FailureReason () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (FailureReason
err :: FailureReason) -> case FailureReason -> Bool
pred FailureReason
err of
      Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool
False -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected test to fail with a failure matching the predicate, but got a different failure: '#{err}'|]
    Right () -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected test to fail, but it succeeded|]

-- | Asserts that an action should throw an exception. Accepts a predicate to determine if the exception matches.
shouldThrow :: (HasCallStack, MonadThrow m, MonadCatch m, MonadIO m, Exception e) =>
  m a
  -- ^ The action to run.
  -> (e -> Bool)
  -- ^ A predicate on the exception to determine if it's as expected.
  -> m ()
shouldThrow :: m a -> (e -> Bool) -> m ()
shouldThrow m a
action e -> Bool
f = do
  m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
action m (Either e a) -> (Either e a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
_ -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected exception to be thrown.|]
    Left e
e | e -> Bool
f e
e -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left e
e -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Exception didn't match predicate: '#{show e}'|]

-- * Assertions

-- | Asserts that two things are equal.
shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
shouldBe :: a -> a -> m ()
shouldBe a
x a
y
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = FailureReason -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (Maybe CallStack -> ShowEqBox -> ShowEqBox -> FailureReason
ExpectedButGot (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) (a -> ShowEqBox
forall s. (Show s, Eq s) => s -> ShowEqBox
SEB a
y) (a -> ShowEqBox
forall s. (Show s, Eq s) => s -> ShowEqBox
SEB a
x))

-- | Asserts that two things are not equal.
shouldNotBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
shouldNotBe :: a -> a -> m ()
shouldNotBe a
x a
y
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = FailureReason -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (Maybe CallStack -> ShowEqBox -> FailureReason
DidNotExpectButGot (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) (a -> ShowEqBox
forall s. (Show s, Eq s) => s -> ShowEqBox
SEB a
y))

-- | Asserts that the given list contains a subsequence.
shouldContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()
shouldContain :: [a] -> [a] -> m ()
shouldContain [a]
haystack [a]
needle = case [a]
needle [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` [a]
haystack of
  Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool
False -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected #{show haystack} to contain #{show needle}|] -- TODO: custom exception type

-- | Asserts that the given list contains an item matching a predicate.
shouldContainPredicate :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> (a -> Bool) -> m ()
shouldContainPredicate :: [a] -> (a -> Bool) -> m ()
shouldContainPredicate [a]
haystack a -> Bool
pred = case (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find a -> Bool
pred [a]
haystack of
  Just a
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Maybe a
Nothing -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected #{show haystack} to contain an item matching the predicate|]

-- | Asserts that the given list does not contain a subsequence.
shouldNotContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()
shouldNotContain :: [a] -> [a] -> m ()
shouldNotContain [a]
haystack [a]
needle = case [a]
needle [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` [a]
haystack of
  Bool
True -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected #{show haystack} not to contain #{show needle}|]
  Bool
False -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Asserts that the given list contains an item matching a predicate.
shouldNotContainPredicate :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> (a -> Bool) -> m ()
shouldNotContainPredicate :: [a] -> (a -> Bool) -> m ()
shouldNotContainPredicate [a]
haystack a -> Bool
pred = case (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find a -> Bool
pred [a]
haystack of
  Maybe a
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Just a
_ -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Expected #{show haystack} not to contain an item matching the predicate|]

-- | Asserts that the given text contains a substring.
textShouldContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()
Text
t textShouldContain :: Text -> Text -> m ()
`textShouldContain` Text
txt = ((Text -> String
T.unpack Text
t) :: String) String -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
[a] -> [a] -> m ()
`shouldContain` (Text -> String
T.unpack Text
txt)

-- | Asserts that the given text does not contain a substring.
textShouldNotContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()
Text
t textShouldNotContain :: Text -> Text -> m ()
`textShouldNotContain` Text
txt = ((Text -> String
T.unpack Text
t) :: String) String -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
[a] -> [a] -> m ()
`shouldNotContain` (Text -> String
T.unpack Text
txt)