{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Chell is a simple and intuitive library for automated testing. It natively
-- supports assertion-based testing, and can use companion libraries
-- such as @chell-quickcheck@ to support more complex testing strategies.
--
-- An example test suite, which verifies the behavior of artithmetic operators.
--
-- @
--{-\# LANGUAGE TemplateHaskell \#-}
--
--import Test.Chell
--
--suite_Math :: Suite
--suite_Math = 'suite' \"math\"
--    [ test_Addition
--    , test_Subtraction
--    ]
--
--test_Addition :: Test
--test_Addition = 'assertions' \"addition\" $ do
--    $'expect' ('equal' (2 + 1) 3)
--    $'expect' ('equal' (1 + 2) 3)
--
--test_Subtraction :: Test
--test_Subtraction = 'assertions' \"subtraction\" $ do
--    $'expect' ('equal' (2 - 1) 1)
--    $'expect' ('equal' (1 - 2) (-1))
--
--main :: IO ()
--main = 'defaultMain' [suite_Math]
-- @
--
-- >$ ghc --make chell-example.hs
-- >$ ./chell-example
-- >PASS: 2 tests run, 2 tests passed
module Test.Chell
  (

  -- * Main
    defaultMain

  -- * Test suites
  , Suite
  , suite
  , suiteName
  , suiteTests

  -- ** Skipping some tests
  , SuiteOrTest
  , skipIf
  , skipWhen

  -- * Basic testing library
  , Assertions
  , assertions
  , IsAssertion
  , Assertion
  , assertionPassed
  , assertionFailed
  , assert
  , expect
  , die
  , trace
  , note
  , afterTest
  , requireLeft
  , requireRight

  -- ** Built-in assertions
  , equal
  , notEqual
  , equalWithin
  , just
  , nothing
  , left
  , right
  , throws
  , throwsEq
  , greater
  , greaterEqual
  , lesser
  , lesserEqual
  , sameItems
  , equalItems
  , IsText
  , equalLines
  , equalLinesWith

  -- * Custom test types
  , Test
  , test
  , testName
  , runTest

  -- ** Test results
  , TestResult (..)

  -- *** Failures
  , Failure
  , failure
  , failureLocation
  , failureMessage

  -- *** Failure locations
  , Location
  , location
  , locationFile
  , locationModule
  , locationLine

  -- ** Test options
  , TestOptions
  , defaultTestOptions
  , testOptionSeed
  , testOptionTimeout
  ) where

import qualified Control.Applicative
import qualified Control.Exception
import           Control.Exception (Exception)
import           Control.Monad (ap, liftM)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.ByteString.Char8
import qualified Data.ByteString.Lazy.Char8
import           Data.Foldable (Foldable, foldMap)
import           Data.List (foldl', intercalate, sort)
import           Data.Maybe (isJust, isNothing)
import           Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import qualified Data.Text
import           Data.Text (Text)
import qualified Data.Text.Lazy

import qualified Language.Haskell.TH as TH

import qualified Patience

import           Test.Chell.Main (defaultMain)
import           Test.Chell.Types

-- | A single pass/fail assertion. Failed assertions include an explanatory
-- message.
data Assertion
  = AssertionPassed
  | AssertionFailed String
  deriving (Assertion -> Assertion -> Bool
(Assertion -> Assertion -> Bool)
-> (Assertion -> Assertion -> Bool) -> Eq Assertion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assertion -> Assertion -> Bool
$c/= :: Assertion -> Assertion -> Bool
== :: Assertion -> Assertion -> Bool
$c== :: Assertion -> Assertion -> Bool
Eq, Int -> Assertion -> ShowS
[Assertion] -> ShowS
Assertion -> String
(Int -> Assertion -> ShowS)
-> (Assertion -> String)
-> ([Assertion] -> ShowS)
-> Show Assertion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assertion] -> ShowS
$cshowList :: [Assertion] -> ShowS
show :: Assertion -> String
$cshow :: Assertion -> String
showsPrec :: Int -> Assertion -> ShowS
$cshowsPrec :: Int -> Assertion -> ShowS
Show)

-- | See 'Assertion'.
assertionPassed :: Assertion
assertionPassed :: Assertion
assertionPassed = Assertion
AssertionPassed

-- | See 'Assertion'.
assertionFailed :: String -> Assertion
assertionFailed :: String -> Assertion
assertionFailed = String -> Assertion
AssertionFailed

-- | See 'assert' and 'expect'.
class IsAssertion a
  where
    runAssertion :: a -> IO Assertion

instance IsAssertion Assertion
  where
    runAssertion :: Assertion -> IO Assertion
runAssertion = Assertion -> IO Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return

instance IsAssertion Bool
  where
    runAssertion :: Bool -> IO Assertion
runAssertion Bool
x =
      Assertion -> IO Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return
        (
          if Bool
x
            then Assertion
assertionPassed
            else String -> Assertion
assertionFailed String
"boolean assertion failed"
        )

instance IsAssertion a => IsAssertion (IO a)
  where
    runAssertion :: IO a -> IO Assertion
runAssertion IO a
x = IO a
x IO a -> (a -> IO Assertion) -> IO Assertion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO Assertion
forall a. IsAssertion a => a -> IO Assertion
runAssertion

type TestState = (IORef [(String, String)], IORef [IO ()], [Failure])

-- | See 'assertions'.
newtype Assertions a =
  Assertions
    { Assertions a -> TestState -> IO (Maybe a, TestState)
unAssertions :: TestState -> IO (Maybe a, TestState) }

instance Functor Assertions
  where
    fmap :: (a -> b) -> Assertions a -> Assertions b
fmap = (a -> b) -> Assertions a -> Assertions b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Control.Applicative.Applicative Assertions
  where
    pure :: a -> Assertions a
pure = a -> Assertions a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: Assertions (a -> b) -> Assertions a -> Assertions b
(<*>) = Assertions (a -> b) -> Assertions a -> Assertions b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Assertions
  where
    return :: a -> Assertions a
return a
x =
        (TestState -> IO (Maybe a, TestState)) -> Assertions a
forall a. (TestState -> IO (Maybe a, TestState)) -> Assertions a
Assertions (\TestState
s -> (Maybe a, TestState) -> IO (Maybe a, TestState)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x, TestState
s))

    Assertions a
m >>= :: Assertions a -> (a -> Assertions b) -> Assertions b
>>= a -> Assertions b
f =
        (TestState -> IO (Maybe b, TestState)) -> Assertions b
forall a. (TestState -> IO (Maybe a, TestState)) -> Assertions a
Assertions
            (\TestState
s ->
              do
                (Maybe a
maybe_a, TestState
s') <- Assertions a -> TestState -> IO (Maybe a, TestState)
forall a. Assertions a -> TestState -> IO (Maybe a, TestState)
unAssertions Assertions a
m TestState
s
                case Maybe a
maybe_a of
                    Maybe a
Nothing -> (Maybe b, TestState) -> IO (Maybe b, TestState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
forall a. Maybe a
Nothing, TestState
s')
                    Just a
a -> Assertions b -> TestState -> IO (Maybe b, TestState)
forall a. Assertions a -> TestState -> IO (Maybe a, TestState)
unAssertions (a -> Assertions b
f a
a) TestState
s'
            )

instance MonadIO Assertions
  where
    liftIO :: IO a -> Assertions a
liftIO IO a
io =
        (TestState -> IO (Maybe a, TestState)) -> Assertions a
forall a. (TestState -> IO (Maybe a, TestState)) -> Assertions a
Assertions
            (\TestState
s ->
              do
                a
x <- IO a
io
                (Maybe a, TestState) -> IO (Maybe a, TestState)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x, TestState
s)
            )

-- | Convert a sequence of pass/fail assertions into a runnable test.
--
-- @
-- test_Equality :: Test
-- test_Equality = assertions \"equality\" $ do
--     $assert (1 == 1)
--     $assert (equal 1 1)
-- @
assertions :: String -> Assertions a -> Test
assertions :: String -> Assertions a -> Test
assertions String
name Assertions a
testm =
    String -> (TestOptions -> IO TestResult) -> Test
test String
name ((TestOptions -> IO TestResult) -> Test)
-> (TestOptions -> IO TestResult) -> Test
forall a b. (a -> b) -> a -> b
$ \TestOptions
opts ->
      do
        IORef [(String, String)]
noteRef <- [(String, String)] -> IO (IORef [(String, String)])
forall a. a -> IO (IORef a)
newIORef []
        IORef [IO ()]
afterTestRef <- [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []

        let
            getNotes :: IO [(String, String)]
getNotes = ([(String, String)] -> [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, String)] -> [(String, String)]
forall a. [a] -> [a]
reverse (IORef [(String, String)] -> IO [(String, String)]
forall a. IORef a -> IO a
readIORef IORef [(String, String)]
noteRef)

        let
            getResult :: IO TestResult
getResult =
              do
                (Maybe a, TestState)
res <- Assertions a -> TestState -> IO (Maybe a, TestState)
forall a. Assertions a -> TestState -> IO (Maybe a, TestState)
unAssertions Assertions a
testm (IORef [(String, String)]
noteRef, IORef [IO ()]
afterTestRef, [])
                case (Maybe a, TestState)
res of
                    (Maybe a
_, (IORef [(String, String)]
_, IORef [IO ()]
_, [])) ->
                      do
                        [(String, String)]
notes <- IO [(String, String)]
getNotes
                        TestResult -> IO TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)] -> TestResult
TestPassed [(String, String)]
notes)
                    (Maybe a
_, (IORef [(String, String)]
_, IORef [IO ()]
_, [Failure]
fs)) ->
                      do
                        [(String, String)]
notes <- IO [(String, String)]
getNotes
                        TestResult -> IO TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)] -> [Failure] -> TestResult
TestFailed [(String, String)]
notes ([Failure] -> [Failure]
forall a. [a] -> [a]
reverse [Failure]
fs))

        IO TestResult -> IO () -> IO TestResult
forall a b. IO a -> IO b -> IO a
Control.Exception.finally
            (TestOptions
-> IO TestResult -> IO [(String, String)] -> IO TestResult
handleJankyIO TestOptions
opts IO TestResult
getResult IO [(String, String)]
getNotes)
            (IORef [IO ()] -> IO ()
runAfterTest IORef [IO ()]
afterTestRef)

runAfterTest :: IORef [IO ()] -> IO ()
runAfterTest :: IORef [IO ()] -> IO ()
runAfterTest IORef [IO ()]
ref = IORef [IO ()] -> IO [IO ()]
forall a. IORef a -> IO a
readIORef IORef [IO ()]
ref IO [IO ()] -> ([IO ()] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [IO ()] -> IO ()
forall b. [IO b] -> IO ()
loop
  where
    loop :: [IO b] -> IO ()
loop [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    loop (IO b
io:[IO b]
ios) = IO () -> IO b -> IO ()
forall a b. IO a -> IO b -> IO a
Control.Exception.finally ([IO b] -> IO ()
loop [IO b]
ios) IO b
io

addFailure :: Maybe TH.Loc -> String -> Assertions ()
addFailure :: Maybe Loc -> String -> Assertions ()
addFailure Maybe Loc
maybe_loc String
msg =
    (TestState -> IO (Maybe (), TestState)) -> Assertions ()
forall a. (TestState -> IO (Maybe a, TestState)) -> Assertions a
Assertions ((TestState -> IO (Maybe (), TestState)) -> Assertions ())
-> (TestState -> IO (Maybe (), TestState)) -> Assertions ()
forall a b. (a -> b) -> a -> b
$ \(IORef [(String, String)]
notes, IORef [IO ()]
afterTestRef, [Failure]
fs) ->
      do
        let
            loc :: Maybe Location
loc =
              do
                Loc
th_loc <- Maybe Loc
maybe_loc
                Location -> Maybe Location
forall (m :: * -> *) a. Monad m => a -> m a
return (Location -> Maybe Location) -> Location -> Maybe Location
forall a b. (a -> b) -> a -> b
$ Location
location
                    { locationFile :: String
locationFile = Loc -> String
TH.loc_filename Loc
th_loc
                    , locationModule :: String
locationModule = Loc -> String
TH.loc_module Loc
th_loc
                    , locationLine :: Maybe Integer
locationLine = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Loc -> (Int, Int)
TH.loc_start Loc
th_loc)))
                    }
        let
            f :: Failure
f = Failure
failure
                { failureLocation :: Maybe Location
failureLocation = Maybe Location
loc
                , failureMessage :: String
failureMessage = String
msg
                }
        (Maybe (), TestState) -> IO (Maybe (), TestState)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just (), (IORef [(String, String)]
notes, IORef [IO ()]
afterTestRef, Failure
f Failure -> [Failure] -> [Failure]
forall a. a -> [a] -> [a]
: [Failure]
fs))

-- | Cause a test to immediately fail, with a message.
--
-- 'die' is a Template Haskell macro, to retain the source-file location from
-- which it was used. Its effective type is:
--
-- @
-- $die :: 'String' -> 'Assertions' a
-- @
die :: TH.Q TH.Exp
die :: Q Exp
die =
  do
    Loc
loc <- Q Loc
TH.location
    let
        qloc :: Q Exp
qloc = Loc -> Q Exp
liftLoc Loc
loc
    [| \msg -> dieAt $qloc ("die: " ++ msg) |]

dieAt :: TH.Loc -> String -> Assertions a
dieAt :: Loc -> String -> Assertions a
dieAt Loc
loc String
msg =
  do
    Maybe Loc -> String -> Assertions ()
addFailure (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc) String
msg
    (TestState -> IO (Maybe a, TestState)) -> Assertions a
forall a. (TestState -> IO (Maybe a, TestState)) -> Assertions a
Assertions (\TestState
s -> (Maybe a, TestState) -> IO (Maybe a, TestState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, TestState
s))

-- | Print a message from within a test. This is just a helper for debugging,
-- so you don't have to import @Debug.Trace@. Messages will be prefixed with
-- the filename and line number where @$trace@ was called.
--
-- 'trace' is a Template Haskell macro, to retain the source-file location
-- from which it was used. Its effective type is:
--
-- @
-- $trace :: 'String' -> 'Assertions' ()
-- @
trace :: TH.Q TH.Exp
trace :: Q Exp
trace =
  do
    Loc
loc <- Q Loc
TH.location
    let
        qloc :: Q Exp
qloc = Loc -> Q Exp
liftLoc Loc
loc
    [| traceAt $qloc |]

traceAt :: TH.Loc -> String -> Assertions ()
traceAt :: Loc -> String -> Assertions ()
traceAt Loc
loc String
msg =
  IO () -> Assertions ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Assertions ()) -> IO () -> Assertions ()
forall a b. (a -> b) -> a -> b
$
    do
      let
          file :: String
file = Loc -> String
TH.loc_filename Loc
loc
          line :: Int
line = (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Loc -> (Int, Int)
TH.loc_start Loc
loc)
      String -> IO ()
putStr (String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] ")
      String -> IO ()
putStrLn String
msg

-- | Attach a note to a test run. Notes will be printed to stdout and
-- included in reports, even if the test fails or aborts. Notes are useful for
-- debugging failing tests.
note :: String -> String -> Assertions ()
note :: String -> String -> Assertions ()
note String
key String
value =
    (TestState -> IO (Maybe (), TestState)) -> Assertions ()
forall a. (TestState -> IO (Maybe a, TestState)) -> Assertions a
Assertions (\(IORef [(String, String)]
notes, IORef [IO ()]
afterTestRef, [Failure]
fs) ->
      do
        IORef [(String, String)]
-> ([(String, String)] -> [(String, String)]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(String, String)]
notes ((String
key, String
value) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:)
        (Maybe (), TestState) -> IO (Maybe (), TestState)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just (), (IORef [(String, String)]
notes, IORef [IO ()]
afterTestRef, [Failure]
fs)))

-- | Register an IO action to be run after the test completes. This action
-- will run even if the test failed or aborted.
afterTest :: IO () -> Assertions ()
afterTest :: IO () -> Assertions ()
afterTest IO ()
io =
    (TestState -> IO (Maybe (), TestState)) -> Assertions ()
forall a. (TestState -> IO (Maybe a, TestState)) -> Assertions a
Assertions (\(IORef [(String, String)]
notes, IORef [IO ()]
ref, [Failure]
fs) ->
      do
        IORef [IO ()] -> ([IO ()] -> [IO ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [IO ()]
ref (IO ()
io IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:)
        (Maybe (), TestState) -> IO (Maybe (), TestState)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just (), (IORef [(String, String)]
notes, IORef [IO ()]
ref, [Failure]
fs)))

-- | Require an 'Either' value to be 'Left', and return its contents. If
-- the value is 'Right', fail the test.
--
-- 'requireLeft' is a Template Haskell macro, to retain the source-file
-- location from which it was used. Its effective type is:
--
-- @
-- $requireLeft :: 'Show' b => 'Either' a b -> 'Assertions' a
-- @
requireLeft :: TH.Q TH.Exp
requireLeft :: Q Exp
requireLeft =
  do
    Loc
loc <- Q Loc
TH.location
    let
        qloc :: Q Exp
qloc = Loc -> Q Exp
liftLoc Loc
loc
    [| requireLeftAt $qloc |]

requireLeftAt :: Show b => TH.Loc -> Either a b -> Assertions a
requireLeftAt :: Loc -> Either a b -> Assertions a
requireLeftAt Loc
loc Either a b
val =
    case Either a b
val of
        Left a
a -> a -> Assertions a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Right b
b ->
          do
            let
                dummy :: Either () b
dummy = b -> Either () b
forall a b. b -> Either a b
Right b
b Either () b -> Either () b -> Either () b
forall a. a -> a -> a
`asTypeOf` () -> Either () b
forall a b. a -> Either a b
Left ()
            Loc -> String -> Assertions a
forall a. Loc -> String -> Assertions a
dieAt Loc
loc (String
"requireLeft: received " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Either () b -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Either () b
dummy String
"")

-- | Require an 'Either' value to be 'Right', and return its contents. If
-- the value is 'Left', fail the test.
--
-- 'requireRight' is a Template Haskell macro, to retain the source-file
-- location from which it was used. Its effective type is:
--
-- @
-- $requireRight :: 'Show' a => 'Either' a b -> 'Assertions' b
-- @
requireRight :: TH.Q TH.Exp
requireRight :: Q Exp
requireRight =
  do
    Loc
loc <- Q Loc
TH.location
    let
        qloc :: Q Exp
qloc = Loc -> Q Exp
liftLoc Loc
loc
    [| requireRightAt $qloc |]

requireRightAt :: Show a => TH.Loc -> Either a b -> Assertions b
requireRightAt :: Loc -> Either a b -> Assertions b
requireRightAt Loc
loc Either a b
val =
    case Either a b
val of
        Left a
a ->
          do
            let
                dummy :: Either a ()
dummy = a -> Either a ()
forall a b. a -> Either a b
Left a
a Either a () -> Either a () -> Either a ()
forall a. a -> a -> a
`asTypeOf` () -> Either a ()
forall a b. b -> Either a b
Right ()
            Loc -> String -> Assertions b
forall a. Loc -> String -> Assertions a
dieAt Loc
loc (String
"requireRight: received " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Either a () -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Either a ()
dummy String
"")
        Right b
b -> b -> Assertions b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b

liftLoc :: TH.Loc -> TH.Q TH.Exp
liftLoc :: Loc -> Q Exp
liftLoc Loc
loc =
    [| TH.Loc filename package module_ start end |]
  where
    filename :: String
filename = Loc -> String
TH.loc_filename Loc
loc
    package :: String
package = Loc -> String
TH.loc_package Loc
loc
    module_ :: String
module_ = Loc -> String
TH.loc_module Loc
loc
    start :: (Int, Int)
start = Loc -> (Int, Int)
TH.loc_start Loc
loc
    end :: (Int, Int)
end = Loc -> (Int, Int)
TH.loc_end Loc
loc

assertAt :: IsAssertion assertion => TH.Loc -> Bool -> assertion -> Assertions ()
assertAt :: Loc -> Bool -> assertion -> Assertions ()
assertAt Loc
loc Bool
fatal assertion
assertion =
  do
    Assertion
result <- IO Assertion -> Assertions Assertion
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (assertion -> IO Assertion
forall a. IsAssertion a => a -> IO Assertion
runAssertion assertion
assertion)
    case Assertion
result of
        Assertion
AssertionPassed -> () -> Assertions ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        AssertionFailed String
err ->
            if Bool
fatal
                then Loc -> String -> Assertions ()
forall a. Loc -> String -> Assertions a
dieAt Loc
loc String
err
                else Maybe Loc -> String -> Assertions ()
addFailure (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc) String
err

-- | Check an assertion. If the assertion fails, the test will immediately
-- fail.
--
-- The assertion to check can be a boolean value, an 'Assertion', or an IO
-- action returning one of the above.
--
-- 'assert' is a Template Haskell macro, to retain the source-file location
-- from which it was used. Its effective type is:
--
-- @
-- $assert :: 'IsAssertion' assertion => assertion -> 'Assertions' ()
-- @
assert :: TH.Q TH.Exp
assert :: Q Exp
assert =
  do
    Loc
loc <- Q Loc
TH.location
    let
        qloc :: Q Exp
qloc = Loc -> Q Exp
liftLoc Loc
loc
    [| assertAt $qloc True |]

-- | Check an assertion. If the assertion fails, the test will continue to
-- run until it finishes, a call to 'assert' fails, or the test runs 'die'.
--
-- The assertion to check can be a boolean value, an 'Assertion', or an IO
-- action returning one of the above.
--
-- 'expect' is a Template Haskell macro, to retain the source-file location
-- from which it was used. Its effective type is:
--
-- @
-- $expect :: 'IsAssertion' assertion => assertion -> 'Assertions' ()
-- @
expect :: TH.Q TH.Exp
expect :: Q Exp
expect =
  do
    Loc
loc <- Q Loc
TH.location
    let
        qloc :: Q Exp
qloc = Loc -> Q Exp
liftLoc Loc
loc
    [| assertAt $qloc False |]

assertBool :: Bool -> String -> Assertion
assertBool :: Bool -> String -> Assertion
assertBool Bool
True  String
_   = Assertion
assertionPassed
assertBool Bool
False String
err = String -> Assertion
AssertionFailed String
err

-- | Assert that two values are equal.
equal :: (Show a, Eq a) => a -> a -> Assertion
equal :: a -> a -> Assertion
equal a
x a
y =
    Bool -> String -> Assertion
assertBool
        (a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y)
        (String
"equal: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not equal to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y)

-- | Assert that two values are not equal.
notEqual :: (Eq a, Show a) => a -> a -> Assertion
notEqual :: a -> a -> Assertion
notEqual a
x a
y =
    Bool -> String -> Assertion
assertBool
        (a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y)
        (String
"notEqual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is equal to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y)

-- | Assert that two values are within some delta of each other.
equalWithin :: (Real a, Show a) => a -> a
                                -> a -- ^ delta
                                -> Assertion
equalWithin :: a -> a -> a -> Assertion
equalWithin a
x a
y a
delta =
    Bool -> String -> Assertion
assertBool
        ((a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
delta a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y) Bool -> Bool -> Bool
&& (a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
delta a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
y))
        (String
"equalWithin: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not within " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
delta String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y)

-- | Assert that some value is @Just@.
just :: Maybe a -> Assertion
just :: Maybe a -> Assertion
just Maybe a
x = Bool -> String -> Assertion
assertBool (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
x) (String
"just: received Nothing")

-- | Assert that some value is @Nothing@.
nothing :: Show a => Maybe a -> Assertion
nothing :: Maybe a -> Assertion
nothing Maybe a
x =
    Bool -> String -> Assertion
assertBool
        (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
x)
        (String
"nothing: received " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Maybe a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe a
x String
"")

-- | Assert that some value is @Left@.
left :: Show b => Either a b -> Assertion
left :: Either a b -> Assertion
left (Left a
_) = Assertion
assertionPassed
left (Right b
b) = String -> Assertion
assertionFailed (String
"left: received " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Either () b -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Either () b
dummy String
"")
  where
    dummy :: Either () b
dummy = b -> Either () b
forall a b. b -> Either a b
Right b
b Either () b -> Either () b -> Either () b
forall a. a -> a -> a
`asTypeOf` () -> Either () b
forall a b. a -> Either a b
Left ()

-- | Assert that some value is @Right@.
right :: Show a => Either a b -> Assertion
right :: Either a b -> Assertion
right (Right b
_) = Assertion
assertionPassed
right (Left a
a) = String -> Assertion
assertionFailed (String
"right: received " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Either a () -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Either a ()
dummy String
"")
  where
    dummy :: Either a ()
dummy = a -> Either a ()
forall a b. a -> Either a b
Left a
a Either a () -> Either a () -> Either a ()
forall a. a -> a -> a
`asTypeOf` () -> Either a ()
forall a b. b -> Either a b
Right ()

-- | Assert that some computation throws an exception matching the provided
-- predicate. This is mostly useful for exception types which do not have an
-- instance for @Eq@, such as @'Control.Exception.ErrorCall'@.
throws :: Exception err => (err -> Bool) -> IO a -> IO Assertion
throws :: (err -> Bool) -> IO a -> IO Assertion
throws err -> Bool
p IO a
io =
  do
    Either err a
either_exc <- IO a -> IO (Either err a)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try IO a
io
    Assertion -> IO Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return (Assertion -> IO Assertion) -> Assertion -> IO Assertion
forall a b. (a -> b) -> a -> b
$
        case Either err a
either_exc of
            Left err
exc ->
                if err -> Bool
p err
exc
                    then Assertion
assertionPassed
                    else String -> Assertion
assertionFailed (String
"throws: exception " String -> ShowS
forall a. [a] -> [a] -> [a]
++ err -> String
forall a. Show a => a -> String
show err
exc String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                          String
" did not match predicate")
            Right a
_ -> String -> Assertion
assertionFailed String
"throws: no exception thrown"

-- | Assert that some computation throws an exception equal to the given
-- exception. This is better than just checking that the correct type was
-- thrown, because the test can also verify the exception contains the correct
-- information.
throwsEq :: (Eq err, Exception err, Show err) => err -> IO a -> IO Assertion
throwsEq :: err -> IO a -> IO Assertion
throwsEq err
expected IO a
io =
  do
    Either err a
either_exc <- IO a -> IO (Either err a)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try IO a
io
    Assertion -> IO Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return (Assertion -> IO Assertion) -> Assertion -> IO Assertion
forall a b. (a -> b) -> a -> b
$
        case Either err a
either_exc of
            Left err
exc ->
                if err
exc err -> err -> Bool
forall a. Eq a => a -> a -> Bool
== err
expected
                    then Assertion
assertionPassed
                    else String -> Assertion
assertionFailed (String
"throwsEq: exception " String -> ShowS
forall a. [a] -> [a] -> [a]
++ err -> String
forall a. Show a => a -> String
show err
exc String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                          String
" is not equal to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ err -> String
forall a. Show a => a -> String
show err
expected)
            Right a
_ -> String -> Assertion
assertionFailed String
"throwsEq: no exception thrown"

-- | Assert a value is greater than another.
greater :: (Ord a, Show a) => a -> a -> Assertion
greater :: a -> a -> Assertion
greater a
x a
y =
    Bool -> String -> Assertion
assertBool
        (a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
y)
        (String
"greater: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not greater than " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y)

-- | Assert a value is greater than or equal to another.
greaterEqual :: (Ord a, Show a) => a -> a -> Assertion
greaterEqual :: a -> a -> Assertion
greaterEqual a
x a
y =
    Bool -> String -> Assertion
assertBool
        (a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
y)
        (String
"greaterEqual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not greater than or equal to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y)

-- | Assert a value is less than another.
lesser :: (Ord a, Show a) => a -> a -> Assertion
lesser :: a -> a -> Assertion
lesser a
x a
y =
    Bool -> String -> Assertion
assertBool
        (a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y)
        (String
"lesser: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not less than " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y)

-- | Assert a value is less than or equal to another.
lesserEqual :: (Ord a, Show a) => a -> a -> Assertion
lesserEqual :: a -> a -> Assertion
lesserEqual a
x a
y =
    Bool -> String -> Assertion
assertBool
        (a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y)
        (String
"lesserEqual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not less than or equal to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y)

-- | Assert that two containers have the same items, in any order.
sameItems :: (Foldable container, Show item, Ord item) =>
    container item -> container item -> Assertion
sameItems :: container item -> container item -> Assertion
sameItems container item
x container item
y = String
-> ([item] -> [item])
-> container item
-> container item
-> Assertion
forall (container :: * -> *) item.
(Foldable container, Show item, Ord item) =>
String
-> ([item] -> [item])
-> container item
-> container item
-> Assertion
equalDiff' String
"sameItems" [item] -> [item]
forall a. Ord a => [a] -> [a]
sort container item
x container item
y

-- | Assert that two containers have the same items, in the same order.
equalItems :: (Foldable container, Show item, Ord item) =>
    container item -> container item -> Assertion
equalItems :: container item -> container item -> Assertion
equalItems container item
x container item
y = String
-> ([item] -> [item])
-> container item
-> container item
-> Assertion
forall (container :: * -> *) item.
(Foldable container, Show item, Ord item) =>
String
-> ([item] -> [item])
-> container item
-> container item
-> Assertion
equalDiff' String
"equalItems" [item] -> [item]
forall a. a -> a
id container item
x container item
y

equalDiff' :: (Foldable container, Show item, Ord item)
           => String
           -> ([item]
           -> [item])
           -> container item
           -> container item
           -> Assertion
equalDiff' :: String
-> ([item] -> [item])
-> container item
-> container item
-> Assertion
equalDiff' String
label [item] -> [item]
norm container item
x container item
y = [item] -> [item] -> Assertion
forall a. (Show a, Ord a) => [a] -> [a] -> Assertion
checkDiff (container item -> [item]
items container item
x) (container item -> [item]
items container item
y)
  where
    items :: container item -> [item]
items = [item] -> [item]
norm ([item] -> [item])
-> (container item -> [item]) -> container item -> [item]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (item -> [item]) -> container item -> [item]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (item -> [item] -> [item]
forall a. a -> [a] -> [a]
:[])
    checkDiff :: [a] -> [a] -> Assertion
checkDiff [a]
xs [a]
ys =
        case [Item a] -> (Bool, String)
forall (t :: * -> *) a.
(Foldable t, Show a) =>
t (Item a) -> (Bool, String)
checkItems ([a] -> [a] -> [Item a]
forall a. Ord a => [a] -> [a] -> [Item a]
Patience.diff [a]
xs [a]
ys) of
            (Bool
same, String
diff) -> Bool -> String -> Assertion
assertBool Bool
same String
diff

    checkItems :: t (Item a) -> (Bool, String)
checkItems t (Item a)
diffItems =
        case ((Bool, [String]) -> Item a -> (Bool, [String]))
-> (Bool, [String]) -> t (Item a) -> (Bool, [String])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Bool, [String]) -> Item a -> (Bool, [String])
forall a. Show a => (Bool, [String]) -> Item a -> (Bool, [String])
checkItem (Bool
True, []) t (Item a)
diffItems of
            (Bool
same, [String]
diff) -> (Bool
same, ShowS
errorMsg (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
diff)))

    checkItem :: (Bool, [String]) -> Item a -> (Bool, [String])
checkItem (Bool
same, [String]
acc) Item a
item =
        case Item a
item of
            Patience.Old a
t -> (Bool
False, (String
"\t- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
t) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc)
            Patience.New a
t -> (Bool
False, (String
"\t+ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
t) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc)
            Patience.Both a
t a
_-> (Bool
same, (String
"\t  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
t) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc)

    errorMsg :: ShowS
errorMsg String
diff = String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": items differ\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
diff

-- | Class for types which can be treated as text; see 'equalLines'.
class IsText a
  where
    toLines :: a -> [a]
    unpack :: a -> String

instance IsText String
  where
    toLines :: String -> [String]
toLines = String -> [String]
lines
    unpack :: ShowS
unpack = ShowS
forall a. a -> a
id

instance IsText Text
  where
    toLines :: Text -> [Text]
toLines = Text -> [Text]
Data.Text.lines
    unpack :: Text -> String
unpack = Text -> String
Data.Text.unpack

instance IsText Data.Text.Lazy.Text
  where
    toLines :: Text -> [Text]
toLines = Text -> [Text]
Data.Text.Lazy.lines
    unpack :: Text -> String
unpack = Text -> String
Data.Text.Lazy.unpack

-- | Uses @Data.ByteString.Char8@
instance IsText Data.ByteString.Char8.ByteString
  where
    toLines :: ByteString -> [ByteString]
toLines = ByteString -> [ByteString]
Data.ByteString.Char8.lines
    unpack :: ByteString -> String
unpack = ByteString -> String
Data.ByteString.Char8.unpack

-- | Uses @Data.ByteString.Lazy.Char8@
instance IsText Data.ByteString.Lazy.Char8.ByteString
  where
    toLines :: ByteString -> [ByteString]
toLines = ByteString -> [ByteString]
Data.ByteString.Lazy.Char8.lines
    unpack :: ByteString -> String
unpack = ByteString -> String
Data.ByteString.Lazy.Char8.unpack

-- | Assert that two pieces of text are equal. This uses a diff algorithm
-- to check line-by-line, so the error message will be easier to read on
-- large inputs.
equalLines :: (Ord a, IsText a) => a -> a -> Assertion
equalLines :: a -> a -> Assertion
equalLines a
x a
y = String -> [a] -> [a] -> Assertion
forall a. (Ord a, IsText a) => String -> [a] -> [a] -> Assertion
checkLinesDiff String
"equalLines" (a -> [a]
forall a. IsText a => a -> [a]
toLines a
x) (a -> [a]
forall a. IsText a => a -> [a]
toLines a
y)

-- | Variant of 'equalLines' which allows a user-specified line-splitting
-- predicate.
equalLinesWith :: Ord a => (a -> [String]) -> a -> a -> Assertion
equalLinesWith :: (a -> [String]) -> a -> a -> Assertion
equalLinesWith a -> [String]
toStringLines a
x a
y = String -> [String] -> [String] -> Assertion
forall a. (Ord a, IsText a) => String -> [a] -> [a] -> Assertion
checkLinesDiff String
"equalLinesWith" (a -> [String]
toStringLines a
x) (a -> [String]
toStringLines a
y)

checkLinesDiff :: (Ord a, IsText a) => String -> [a] -> [a] -> Assertion
checkLinesDiff :: String -> [a] -> [a] -> Assertion
checkLinesDiff String
label = [a] -> [a] -> Assertion
forall a. (IsText a, Ord a) => [a] -> [a] -> Assertion
go
  where
    go :: [a] -> [a] -> Assertion
go [a]
xs [a]
ys =
        case [Item a] -> (Bool, String)
forall (t :: * -> *) a.
(Foldable t, IsText a) =>
t (Item a) -> (Bool, String)
checkItems ([a] -> [a] -> [Item a]
forall a. Ord a => [a] -> [a] -> [Item a]
Patience.diff [a]
xs [a]
ys) of
            (Bool
same, String
diff) -> Bool -> String -> Assertion
assertBool Bool
same String
diff

    checkItems :: t (Item a) -> (Bool, String)
checkItems t (Item a)
diffItems =
        case ((Bool, [String]) -> Item a -> (Bool, [String]))
-> (Bool, [String]) -> t (Item a) -> (Bool, [String])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Bool, [String]) -> Item a -> (Bool, [String])
forall a.
IsText a =>
(Bool, [String]) -> Item a -> (Bool, [String])
checkItem (Bool
True, []) t (Item a)
diffItems of
            (Bool
same, [String]
diff) -> (Bool
same, ShowS
errorMsg (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
diff)))

    checkItem :: (Bool, [String]) -> Item a -> (Bool, [String])
checkItem (Bool
same, [String]
acc) Item a
item =
        case Item a
item of
            Patience.Old a
t -> (Bool
False, (String
"\t- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. IsText a => a -> String
unpack a
t) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc)
            Patience.New a
t -> (Bool
False, (String
"\t+ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. IsText a => a -> String
unpack a
t) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc)
            Patience.Both a
t a
_-> (Bool
same, (String
"\t  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. IsText a => a -> String
unpack a
t) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc)

    errorMsg :: ShowS
errorMsg String
diff = String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": lines differ\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
diff