#if MIN_VERSION_base(4,8,1)
#define HAS_SOURCE_LOCATIONS
#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 Data.Algorithm.Diff (getDiff, Diff(..))
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
#ifdef 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 = Test.HUnit.assertFailure
with_loc(expectTrue, String -> Bool -> Expectation)
expectTrue msg b = unless b (expectationFailure msg)
infix 1 `shouldBe`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn`, `shouldThrow`
infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn`
prettyColor :: Show a => a -> String
prettyColor = hscolour' . nicify . show
where hscolour' = hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False
diffColor :: String -> String -> String
diffColor x y = unlines $ map addSign $ getDiff (lines x) (lines y)
where addSign (Both _ s) = " " ++ s
addSign (First s) = color Red "---" ++ s
addSign (Second s) = color Green "+++" ++ s
color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset]
with_loc(shouldBe, (Show a, Eq a) => a -> a -> Expectation)
actual `shouldBe` expected = expectTrue (diffColor (prettyColor expected) (prettyColor actual)) (actual == expected)
with_loc(shouldSatisfy, (Show a) => a -> (a -> Bool) -> Expectation)
v `shouldSatisfy` p = expectTrue ("predicate failed on: " ++ show v) (p v)
with_loc(compareWith, (Show a, Eq a) => (a -> a -> Bool) -> String -> a -> a -> Expectation)
compareWith comparator errorDesc result expected = expectTrue errorMsg (comparator expected result)
where
errorMsg = show result ++ " " ++ errorDesc ++ " " ++ show expected
with_loc(shouldStartWith, (Show a, Eq a) => [a] -> [a] -> Expectation)
shouldStartWith = compareWith isPrefixOf "does not start with"
with_loc(shouldEndWith, (Show a, Eq a) => [a] -> [a] -> Expectation)
shouldEndWith = compareWith isSuffixOf "does not end with"
with_loc(shouldContain, (Show a, Eq a) => [a] -> [a] -> Expectation)
shouldContain = compareWith isInfixOf "does not contain"
with_loc(shouldMatchList, (Show a, Eq a) => [a] -> [a] -> Expectation)
xs `shouldMatchList` ys = maybe (return ()) expectationFailure (matchList xs ys)
with_loc(shouldReturn, (Show a, Eq a) => IO a -> a -> Expectation)
action `shouldReturn` expected = action >>= (`shouldBe` expected)
with_loc(shouldNotBe, (Show a, Eq a) => a -> a -> Expectation)
actual `shouldNotBe` notExpected = expectTrue ("not expected: " ++ show actual) (actual /= notExpected)
with_loc(shouldNotSatisfy, (Show a) => a -> (a -> Bool) -> Expectation)
v `shouldNotSatisfy` p = expectTrue ("predicate succeded on: " ++ show v) ((not . p) v)
with_loc(shouldNotContain, (Show a, Eq a) => [a] -> [a] -> Expectation)
list `shouldNotContain` sublist = expectTrue errorMsg ((not . isInfixOf sublist) list)
where
errorMsg = show list ++ " does contain " ++ show sublist
with_loc(shouldNotReturn, (Show a, Eq a) => IO a -> a -> Expectation)
action `shouldNotReturn` notExpected = action >>= (`shouldNotBe` notExpected)
type Selector a = (a -> Bool)
with_loc(shouldThrow, Exception e => IO a -> Selector e -> Expectation)
action `shouldThrow` p = do
r <- try action
case r of
Right _ ->
expectationFailure $
"did not get expected exception: " ++ exceptionType
Left e ->
(`expectTrue` p e) $
"predicate failed on expected exception: " ++ exceptionType ++ " (" ++ show e ++ ")"
where
exceptionType = (show . typeOf . instanceOf) p
where
instanceOf :: Selector a -> a
instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance"
anyException :: Selector SomeException
anyException = const True
anyErrorCall :: Selector ErrorCall
anyErrorCall = const True
errorCall :: String -> Selector ErrorCall
errorCall s (ErrorCall msg) = s == msg
anyIOException :: Selector IOException
anyIOException = const True
anyArithException :: Selector ArithException
anyArithException = const True