{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-}
{-# LANGUAGE ScopedTypeVariables #-}
--
-- Copyright (c) 2005, 2009   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

{-|
You should not use the functions provided by this module directly.
Instead, for each function @assertXXX_@ defined in this module,
there exist a preprocessor macro @assertXXX@, which provides
the "Location" parameter automatically.
|-}

module Test.Framework.HUnitWrapper (

  -- * General failure
  assertFailure, unitTestPending, unitTestPending',

  -- * Assertions on Bool values
  assertBool_, assertBoolVerbose_,

  -- * Equality assertions
  assertEqual_, assertEqualVerbose_,
  assertEqualPretty_, assertEqualPrettyVerbose_,
  assertEqualNoShow_, assertEqualNoShowVerbose_,

  -- * Assertions on lists
  assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,
  assertNotEmpty_, assertNotEmptyVerbose_,
  assertEmpty_, assertEmptyVerbose_,

  -- * Assertions for exceptions
  assertThrows_, assertThrowsVerbose_,
  assertThrowsSome_, assertThrowsSomeVerbose_,

  -- * Assertions on Either values
  assertLeft_, assertLeftVerbose_,
  assertLeftNoShow_, assertLeftNoShowVerbose_,
  assertRight_, assertRightVerbose_,
  assertRightNoShow_, assertRightNoShowVerbose_,

  -- * Assertions on Just values
  assertJust_, assertJustVerbose_,
  assertNothing_, assertNothingVerbose_,
  assertNothingNoShow_, assertNothingNoShowVerbose_

) where

import System.IO ( stderr )
import Data.List ( (\\) )
import Control.Exception
import Control.Monad
import qualified Test.HUnit as HU hiding ( assertFailure )

import Test.Framework.TestManager
import Test.Framework.TestManagerInternal
import Test.Framework.Location
import Test.Framework.Utils
import Test.Framework.Pretty

-- WARNING: do not forget to add a preprocessor macro for new assertions!!

assertFailure :: String -> IO a
assertFailure s = unitTestFail s

unitTestPending' :: String -> IO a -> IO a
unitTestPending' msg _ = unitTestPending msg

mkMsg :: String -> String -> String -> String
mkMsg fun extraInfo s =
    if null extraInfo
       then fun ++ (' ':s)
       else fun ++ " (" ++ extraInfo ++ ") " ++ s

--
-- Dirty macro hackery (I'm too lazy ...)
--
#define CreateAssertionsGeneric(__name__, __ctx__, __type__, __ret__) \
__name__##Verbose_ :: __ctx__ Location -> String -> __type__ -> __ret__; \
__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \
__name__##_ :: __ctx__ Location -> __type__ -> __ret__; \
__name__##_ loc = _##__name__##_ #__name__ loc ""

#define CreateAssertionsCtx(__name__, __ctx__, __type__) \
CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, HU.Assertion)

#define CreateAssertions(__name__, __type__) \
CreateAssertionsGeneric(__name__, , __type__, HU.Assertion)

#define CreateAssertionsCtxRet(__name__, __ctx__, __type__, __ret__) \
CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, __ret__)

#define CreateAssertionsRet(__name__, __type__, __ret__) \
CreateAssertionsGeneric(__name__, , __type__, __ret__)

--
-- Boolean Assertions
--
_assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion
_assertBool_ name loc s False =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))
_assertBool_ _ _ _   True = return ()
CreateAssertions(assertBool, Bool)

--
-- Equality Assertions
--
_assertEqual_ :: (Eq a, Show a)
                 => String -> Location -> String -> a -> a -> HU.Assertion
_assertEqual_ name loc s expected actual =
    if expected /= actual
       then assertFailure (mkMsg name s msg)
       else return ()
    where msg = "failed at " ++ showLoc loc ++
                "\n expected: " ++ show expected ++
                "\n but got:  " ++ show actual
CreateAssertionsCtx(assertEqual, (Eq a, Show a), a -> a)

_assertEqualPretty_ :: (Eq a, Pretty a)
                       => String -> Location -> String -> a -> a -> HU.Assertion
_assertEqualPretty_ name loc s expected actual =
    if expected /= actual
       then assertFailure (mkMsg name s msg)
       else return ()
    where msg = "assertEqual failed at " ++ showLoc loc ++
                "\n expected:\n" ++ showPretty expected ++
                "\n but got:\n" ++ showPretty actual
CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), a -> a)

_assertEqualNoShow_ :: Eq a
                    => String -> Location -> String -> a -> a -> HU.Assertion
_assertEqualNoShow_ name loc s expected actual =
    if expected /= actual
       then assertFailure (mkMsg name s ("failed at " ++ showLoc loc))
       else return ()
CreateAssertionsCtx(assertEqualNoShow, Eq a, a -> a)

--
-- Assertions on Lists
--

_assertListsEqualAsSets_ :: (Eq a, Show a)
                   => String -> Location -> String -> [a] -> [a] -> HU.Assertion
_assertListsEqualAsSets_ name loc s expected actual =
    let ne = length expected
        na = length actual
        in case () of
            _| ne /= na ->
                 assertFailure (mkMsg name s
                                ("failed at " ++ showLoc loc
                                 ++ "\n expected length: " ++ show ne
                                 ++ "\n actual length: " ++ show na))
             | not (unorderedEq expected actual) ->
                 assertFailure (mkMsg "assertSetEqual" s
                                ("failed at " ++ showLoc loc
                                 ++ "\n expected: " ++ show expected
                                 ++ "\n actual: " ++ show actual))
             | otherwise -> return ()
    where unorderedEq l1 l2 =
              null (l1 \\ l2) && null (l2 \\ l1)
CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), [a] -> [a])

_assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion
_assertNotEmpty_ name loc s [] =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))
_assertNotEmpty_ _ _ _ (_:_) = return ()
CreateAssertions(assertNotEmpty, [a])

_assertEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion
_assertEmpty_ name loc s (_:_) =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))
_assertEmpty_ _ _ _ [] = return ()
CreateAssertions(assertEmpty, [a])

--
-- Assertions for Exceptions
--

_assertThrows_ :: Exception e
               => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion
_assertThrows_ name loc s x f =
    do res <- try (evaluate x)
       case res of
         Right _ -> assertFailure (mkMsg name s
                                   ("failed at " ++ showLoc loc ++
                                    ": no exception was thrown"))
         Left e -> if f e then return ()
                   else assertFailure (mkMsg name s
                                       ("failed at " ++
                                        showLoc loc ++
                                        ": wrong exception was thrown: " ++
                                        show e))
CreateAssertionsCtx(assertThrows, Exception e, a -> (e -> Bool))

_assertThrowsSome_ :: String -> Location -> String -> a -> HU.Assertion
_assertThrowsSome_ name loc s x =
    _assertThrows_ name loc s x (\ (e::SomeException) -> True)
CreateAssertions(assertThrowsSome, a)

--
-- Assertions on Either
--

_assertLeft_ :: forall a b . Show b
             => String -> Location -> String -> Either a b -> IO a
_assertLeft_ _ _ _ (Left x) = return x
_assertLeft_ name loc s (Right x) =
    assertFailure (mkMsg name s
                   ("failed at " ++ showLoc loc ++
                    ": expected a Left value, given " ++
                    show (Right x :: Either b b)))
CreateAssertionsCtxRet(assertLeft, Show b, Either a b, IO a)

_assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a
_assertLeftNoShow_ _ _ _ (Left x) = return x
_assertLeftNoShow_ name loc s (Right _) =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++
                                 ": expected a Left value, given a Right value"))
CreateAssertionsRet(assertLeftNoShow, Either a b, IO a)

_assertRight_ :: forall a b . Show a
              => String -> Location -> String -> Either a b -> IO b
_assertRight_ _ _ _ (Right x) = return x
_assertRight_ name loc s (Left x) =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++
                                 ": expected a Right value, given " ++
                                 show (Left x :: Either a a)))
CreateAssertionsCtxRet(assertRight, Show a, Either a b, IO b)

_assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b
_assertRightNoShow_ _ _ _ (Right x) = return x
_assertRightNoShow_ name loc s (Left _) =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++
                                 ": expected a Right value, given a Left value"))
CreateAssertionsRet(assertRightNoShow, Either a b, IO b)

--
-- Assertions on Maybe
--

_assertJust_ :: String -> Location -> String -> Maybe a -> IO a
_assertJust_ _ _ _ (Just x) = return x
_assertJust_ name loc s Nothing =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++
                                 ": expected a Just value, given Nothing"))
CreateAssertionsRet(assertJust, Maybe a, IO a)

_assertNothing_ :: Show a
                => String -> Location -> String -> Maybe a -> HU.Assertion
_assertNothing_ _ _ _ Nothing = return ()
_assertNothing_ name loc s jx =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++
                                 ": expected Nothing, given " ++ show jx))
CreateAssertionsCtx(assertNothing, Show a, Maybe a)

_assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion
_assertNothingNoShow_ _ _ _ Nothing = return ()
_assertNothingNoShow_ name loc s _ =
    assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++
                                 ": expected Nothing, given a Just value"))
CreateAssertions(assertNothingNoShow, Maybe a)