{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
#if MIN_VERSION_base(4,8,1)
#define HAS_SOURCE_LOCATIONS
{-# LANGUAGE ImplicitParams #-}
#endif
module Test.Hspec.Expectations.Pretty (
Expectation
, expectationFailure
, shouldBe
, shouldSatisfy
, shouldStartWith
, shouldEndWith
, shouldContain
, shouldMatchList
, shouldReturn
, shouldNotBe
, shouldNotSatisfy
, shouldNotContain
, shouldNotReturn
, shouldThrow
, Selector
, anyException
, anyErrorCall
, anyIOException
, anyArithException
, 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]
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)
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
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"
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"
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"
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)
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)
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)
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)
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
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)
type Selector a = (a -> Bool)
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
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