{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
#if MIN_VERSION_base(4,8,1)
#define HAS_SOURCE_LOCATIONS
{-# LANGUAGE ImplicitParams #-}
#endif
-- |
-- Introductory documentation: <https://github.com/sol/hspec-expectations#readme>
module Test.Hspec.Expectations.Pretty (

-- * Setting expectations
  Expectation
, expectationFailure
, shouldBe
, shouldSatisfy
, shouldStartWith
, shouldEndWith
, shouldContain
, shouldMatchList
, shouldReturn

, shouldNotBe
, shouldNotSatisfy
, shouldNotContain
, shouldNotReturn

-- * Expecting exceptions
, shouldThrow

-- ** Selecting exceptions
, Selector

-- ** Predefined type-based selectors
-- |
-- There are predefined selectors for some standard exceptions.  Each selector
-- is just @const True@ with an appropriate type.
, anyException
, anyErrorCall
, anyIOException
, anyArithException

-- ** Combinators for defining value-based selectors
-- |
-- Some exceptions (most prominently `ErrorCall`) have no `Eq` instance.
-- Selecting a specific value would require pattern matching.
--
-- For such exceptions, combinators that construct selectors are provided.
-- Each combinator corresponds to a constructor; it takes the same arguments,
-- and has the same name (but starting with a lower-case letter).
, errorCall
) where

import           Prelude hiding (exp)
import qualified Test.HUnit
import           Control.Exception
import           Data.Typeable
import           Data.List
import           Text.Show.Unicode (ushow)
#if MIN_VERSION_Diff(0,4,0)
import           Data.Algorithm.Diff (getDiff, PolyDiff(First, Second, Both))
#else
import           Data.Algorithm.Diff (getDiff, Diff(First, Second, Both))
#endif

import           Language.Haskell.HsColour hiding (layout)
import           Language.Haskell.HsColour.Colourise (defaultColourPrefs)
import           Language.Haskell.HsColour.ANSI (TerminalType(..))
import           Text.Nicify
import           System.Console.ANSI

import           Control.Monad (unless)

import           Test.Hspec.Expectations.Pretty.Matcher

#if defined(HAS_SOURCE_LOCATIONS) && MIN_VERSION_HUnit(1,4,0)

import           GHC.Stack

#define with_loc(NAME, TYPE) NAME :: (?callStack :: CallStack) => TYPE

#elif defined(HAS_SOURCE_LOCATIONS)

import           GHC.Stack

#define with_loc(NAME, TYPE) NAME :: (?loc :: CallStack) => TYPE

#else

#define with_loc(NAME, TYPE) NAME :: TYPE

#endif

type Expectation = Test.HUnit.Assertion

with_loc(expectationFailure, String -> Expectation)
expectationFailure :: String -> Expectation
expectationFailure = String -> Expectation
forall a. HasCallStack => String -> IO a
Test.HUnit.assertFailure

with_loc(expectTrue, String -> Bool -> Expectation)
expectTrue :: String -> Bool -> Expectation
expectTrue String
msg Bool
b = Bool -> Expectation -> Expectation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (HasCallStack => String -> Expectation
String -> Expectation
expectationFailure String
msg)

infix 1 `shouldBe`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn`, `shouldThrow`
infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn`

prettyColor :: Show a => a -> String
prettyColor :: a -> String
prettyColor = String -> String
hscolour' (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nicify (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
ushow
  where hscolour' :: String -> String
hscolour' = Output
-> ColourPrefs
-> Bool
-> Bool
-> String
-> Bool
-> String
-> String
hscolour (TerminalType -> Output
TTYg TerminalType
Ansi16Colour) ColourPrefs
defaultColourPrefs Bool
False Bool
False String
"" Bool
False

diffColor :: String -> String -> String
diffColor :: String -> String -> String
diffColor String
x String
y = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PolyDiff String String -> String)
-> [PolyDiff String String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PolyDiff String String -> String
addSign ([PolyDiff String String] -> [String])
-> [PolyDiff String String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [PolyDiff String String]
forall a. Eq a => [a] -> [a] -> [Diff a]
getDiff (String -> [String]
lines String
x) (String -> [String]
lines String
y)
  where addSign :: PolyDiff String String -> String
addSign (Both String
_ String
s) = String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        addSign (First  String
s) = Color -> String -> String
color Color
Red String
"---" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        addSign (Second String
s) = Color -> String -> String
color Color
Green String
"+++" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        color :: Color -> String -> String
color Color
c String
s = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode [SGR
Reset]

-- |
-- @actual \`shouldBe\` expected@ sets the expectation that @actual@ is equal
-- to @expected@.
with_loc(shouldBe, (Show a, Eq a) => a -> a -> Expectation)
a
actual shouldBe :: a -> a -> Expectation
`shouldBe` a
expected = HasCallStack => String -> Bool -> Expectation
String -> Bool -> Expectation
expectTrue (String -> String -> String
diffColor (a -> String
forall a. Show a => a -> String
prettyColor a
expected) (a -> String
forall a. Show a => a -> String
prettyColor a
actual)) (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected)

-- |
-- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@.
with_loc(shouldSatisfy, (Show a) => a -> (a -> Bool) -> Expectation)
a
v shouldSatisfy :: a -> (a -> Bool) -> Expectation
`shouldSatisfy` a -> Bool
p = HasCallStack => String -> Bool -> Expectation
String -> Bool -> Expectation
expectTrue (String
"predicate failed on: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
ushow a
v) (a -> Bool
p a
v)

with_loc(compareWith, (Show a, Eq a) => (a -> a -> Bool) -> String -> a -> a -> Expectation)
compareWith :: (a -> a -> Bool) -> String -> a -> a -> Expectation
compareWith a -> a -> Bool
comparator String
errorDesc a
result a
expected = HasCallStack => String -> Bool -> Expectation
String -> Bool -> Expectation
expectTrue String
errorMsg (a -> a -> Bool
comparator a
expected a
result)
  where
    errorMsg :: String
errorMsg = a -> String
forall a. Show a => a -> String
ushow a
result String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorDesc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
ushow a
expected

-- |
-- @list \`shouldStartWith\` prefix@ sets the expectation that @list@ starts with @prefix@,
with_loc(shouldStartWith, (Show a, Eq a) => [a] -> [a] -> Expectation)
shouldStartWith :: [a] -> [a] -> Expectation
shouldStartWith = ([a] -> [a] -> Bool) -> String -> [a] -> [a] -> Expectation
forall a.
(HasCallStack, Show a, Eq a) =>
(a -> a -> Bool) -> String -> a -> a -> Expectation
compareWith [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"does not start with"

-- |
-- @list \`shouldEndWith\` suffix@ sets the expectation that @list@ ends with @suffix@,
with_loc(shouldEndWith, (Show a, Eq a) => [a] -> [a] -> Expectation)
shouldEndWith :: [a] -> [a] -> Expectation
shouldEndWith = ([a] -> [a] -> Bool) -> String -> [a] -> [a] -> Expectation
forall a.
(HasCallStack, Show a, Eq a) =>
(a -> a -> Bool) -> String -> a -> a -> Expectation
compareWith [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
"does not end with"

-- |
-- @list \`shouldContain\` sublist@ sets the expectation that @sublist@ is contained,
-- wholly and intact, anywhere in @list@.
with_loc(shouldContain, (Show a, Eq a) => [a] -> [a] -> Expectation)
shouldContain :: [a] -> [a] -> Expectation
shouldContain = ([a] -> [a] -> Bool) -> String -> [a] -> [a] -> Expectation
forall a.
(HasCallStack, Show a, Eq a) =>
(a -> a -> Bool) -> String -> a -> a -> Expectation
compareWith [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
"does not contain"

-- |
-- @xs \`shouldMatchList\` ys@ sets the expectation that @xs@ has the same
-- elements that @ys@ has, possibly in another order
with_loc(shouldMatchList, (Show a, Eq a) => [a] -> [a] -> Expectation)
[a]
xs shouldMatchList :: [a] -> [a] -> Expectation
`shouldMatchList` [a]
ys = Expectation
-> (String -> Expectation) -> Maybe String -> Expectation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Expectation
forall (m :: * -> *) a. Monad m => a -> m a
return ()) HasCallStack => String -> Expectation
String -> Expectation
expectationFailure ([a] -> [a] -> Maybe String
forall a. (Show a, Eq a) => [a] -> [a] -> Maybe String
matchList [a]
xs [a]
ys)

-- |
-- @action \`shouldReturn\` expected@ sets the expectation that @action@
-- returns @expected@.
with_loc(shouldReturn, (Show a, Eq a) => IO a -> a -> Expectation)
IO a
action shouldReturn :: IO a -> a -> Expectation
`shouldReturn` a
expected = IO a
action IO a -> (a -> Expectation) -> Expectation
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
expected)

-- |
-- @actual \`shouldNotBe\` notExpected@ sets the expectation that @actual@ is not
-- equal to @notExpected@
with_loc(shouldNotBe, (Show a, Eq a) => a -> a -> Expectation)
a
actual shouldNotBe :: a -> a -> Expectation
`shouldNotBe` a
notExpected = HasCallStack => String -> Bool -> Expectation
String -> Bool -> Expectation
expectTrue (String
"not expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
ushow a
actual) (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
notExpected)

-- |
-- @v \`shouldNotSatisfy\` p@ sets the expectation that @p v@ is @False@.
with_loc(shouldNotSatisfy, (Show a) => a -> (a -> Bool) -> Expectation)
a
v shouldNotSatisfy :: a -> (a -> Bool) -> Expectation
`shouldNotSatisfy` a -> Bool
p = HasCallStack => String -> Bool -> Expectation
String -> Bool -> Expectation
expectTrue (String
"predicate succeded on: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
ushow a
v) ((Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) a
v)

-- |
-- @list \`shouldNotContain\` sublist@ sets the expectation that @sublist@ is not
-- contained anywhere in @list@.
with_loc(shouldNotContain, (Show a, Eq a) => [a] -> [a] -> Expectation)
[a]
list shouldNotContain :: [a] -> [a] -> Expectation
`shouldNotContain` [a]
sublist = HasCallStack => String -> Bool -> Expectation
String -> Bool -> Expectation
expectTrue String
errorMsg ((Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf [a]
sublist) [a]
list)
  where
    errorMsg :: String
errorMsg = [a] -> String
forall a. Show a => a -> String
ushow [a]
list String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does contain " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
ushow [a]
sublist

-- |
-- @action \`shouldNotReturn\` notExpected@ sets the expectation that @action@
-- does not return @notExpected@.
with_loc(shouldNotReturn, (Show a, Eq a) => IO a -> a -> Expectation)
IO a
action shouldNotReturn :: IO a -> a -> Expectation
`shouldNotReturn` a
notExpected = IO a
action IO a -> (a -> Expectation) -> Expectation
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldNotBe` a
notExpected)

-- |
-- A @Selector@ is a predicate; it can simultaneously constrain the type and
-- value of an exception.
type Selector a = (a -> Bool)

-- |
-- @action \`shouldThrow\` selector@ sets the expectation that @action@ throws
-- an exception.  The precise nature of the expected exception is described
-- with a 'Selector'.
with_loc(shouldThrow, Exception e => IO a -> Selector e -> Expectation)
IO a
action shouldThrow :: IO a -> Selector e -> Expectation
`shouldThrow` Selector e
p = do
  Either e a
r <- IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
action
  case Either e a
r of
    Right a
_ ->
      HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
        String
"did not get expected exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exceptionType
    Left e
e ->
      (HasCallStack => String -> Bool -> Expectation
String -> Bool -> Expectation
`expectTrue` Selector e
p e
e) (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
        String
"predicate failed on expected exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exceptionType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
ushow e
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  where
    -- a string repsentation of the expected exception's type
    exceptionType :: String
exceptionType = (TypeRep -> String
forall a. Show a => a -> String
ushow (TypeRep -> String)
-> (Selector e -> TypeRep) -> Selector e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (e -> TypeRep) -> (Selector e -> e) -> Selector e -> TypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selector e -> e
forall a. Selector a -> a
instanceOf) Selector e
p
      where
        instanceOf :: Selector a -> a
        instanceOf :: Selector a -> a
instanceOf Selector a
_ = String -> a
forall a. HasCallStack => String -> a
error String
"Test.Hspec.Expectations.shouldThrow: broken Typeable instance"

anyException :: Selector SomeException
anyException :: Selector SomeException
anyException = Bool -> Selector SomeException
forall a b. a -> b -> a
const Bool
True

anyErrorCall :: Selector ErrorCall
anyErrorCall :: Selector ErrorCall
anyErrorCall = Bool -> Selector ErrorCall
forall a b. a -> b -> a
const Bool
True

errorCall :: String -> Selector ErrorCall
errorCall :: String -> Selector ErrorCall
errorCall String
s (ErrorCall String
msg) = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
msg

anyIOException :: Selector IOException
anyIOException :: Selector IOException
anyIOException = Bool -> Selector IOException
forall a b. a -> b -> a
const Bool
True

anyArithException :: Selector ArithException
anyArithException :: Selector ArithException
anyArithException = Bool -> Selector ArithException
forall a b. a -> b -> a
const Bool
True