{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-}

#if MIN_VERSION_base(4,5,0)
{-# LANGUAGE ConstraintKinds #-}
#endif

-- | This is the code copied from the original hunit package (v. 1.2.5.2).
-- with minor modifications
module Test.Tasty.HUnit.Orig where

import qualified Control.Exception as E
import Control.Monad
import Data.Typeable (Typeable)

#if MIN_VERSION_base(4,5,0)
import Data.CallStack
#else
#define HasCallStack Eq ()

callStack :: [a]
callStack = []

-- https://hackage.haskell.org/package/base-4.14.0.0/docs/GHC-Stack.html#t:SrcLoc
data SrcLoc = SrcLoc
  { srcLocPackage   :: String
  , srcLocModule    :: String
  , srcLocFile      :: String
  , srcLocStartLine :: Int
  , srcLocStartCol  :: Int
  , srcLocEndLine   :: Int
  , srcLocEndCol    :: Int
  } deriving (Eq, Show)

#endif

-- Interfaces
-- ----------

-- | An assertion is simply an 'IO' action. Assertion failure is indicated
-- by throwing an exception, typically 'HUnitFailure'.
--
-- Instead of throwing the exception directly, you should use
-- functions like 'assertFailure' and 'assertBool'.
--
-- Test cases are composed of a sequence of one or more assertions.

type Assertion = IO ()

-- | Unconditionally signals that a failure has occured.  All
-- other assertions can be expressed with the form:
--
-- @
--    if conditionIsMet
--        then return ()
--        else assertFailure msg
-- @

assertFailure
  :: HasCallStack
  => String -- ^ A message that is displayed with the assertion failure
  -> IO a
assertFailure :: String -> IO a
assertFailure String
msg = HUnitFailure -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (Maybe SrcLoc -> String -> HUnitFailure
HUnitFailure Maybe SrcLoc
location String
msg)
  where
    location :: Maybe SrcLoc
    location :: Maybe SrcLoc
location = case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse [(String, SrcLoc)]
HasCallStack => [(String, SrcLoc)]
callStack of
      (String
_, SrcLoc
loc) : [(String, SrcLoc)]
_ -> SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just SrcLoc
loc
      [] -> Maybe SrcLoc
forall a. Maybe a
Nothing

-- Conditional Assertion Functions
-- -------------------------------

-- | Asserts that the specified condition holds.
assertBool
  :: HasCallStack
  => String    -- ^ The message that is displayed if the assertion fails
  -> Bool      -- ^ The condition
  -> Assertion
assertBool :: String -> Bool -> Assertion
assertBool String
msg Bool
b = Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
msg)

-- | Asserts that the specified actual value is equal to the expected value.
-- The output message will contain the prefix, the expected value, and the
-- actual value.
--
-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted
-- and only the expected and actual values are output.
assertEqual
  :: (Eq a, Show a, HasCallStack)
  => String -- ^ The message prefix
  -> a      -- ^ The expected value
  -> a      -- ^ The actual value
  -> Assertion
assertEqual :: String -> a -> a -> Assertion
assertEqual String
preface a
expected a
actual =
  Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected) (String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
msg)
 where msg :: String
msg = (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
preface then String
"" else String
preface String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String
"expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n but got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
actual

infix  1 @?, @=?, @?=

-- | Asserts that the specified actual value is equal to the expected value
--   (with the expected value on the left-hand side).
(@=?)
  :: (Eq a, Show a, HasCallStack)
  => a -- ^ The expected value
  -> a -- ^ The actual value
  -> Assertion
a
expected @=? :: a -> a -> Assertion
@=? a
actual = String -> a -> a -> Assertion
forall a.
(Eq a, Show a, HasCallStack) =>
String -> a -> a -> Assertion
assertEqual String
"" a
expected a
actual

-- | Asserts that the specified actual value is equal to the expected value
--   (with the actual value on the left-hand side).
(@?=)
  :: (Eq a, Show a, HasCallStack)
  => a -- ^ The actual value
  -> a -- ^ The expected value
  -> Assertion
a
actual @?= :: a -> a -> Assertion
@?= a
expected = String -> a -> a -> Assertion
forall a.
(Eq a, Show a, HasCallStack) =>
String -> a -> a -> Assertion
assertEqual String
"" a
expected a
actual

-- | An infix and flipped version of 'assertBool'. E.g. instead of
--
-- >assertBool "Non-empty list" (null [1])
--
-- you can write
--
-- >null [1] @? "Non-empty list"
--
-- '@?' is also overloaded to accept @'IO' 'Bool'@ predicates, so instead
-- of
--
-- > do
-- >   e <- doesFileExist "test"
-- >   e @? "File does not exist"
--
-- you can write
--
-- > doesFileExist "test" @? "File does not exist"
(@?) :: (AssertionPredicable t, HasCallStack)
  => t          -- ^ A value of which the asserted condition is predicated
  -> String     -- ^ A message that is displayed if the assertion fails
  -> Assertion
t
predi @? :: t -> String -> Assertion
@? String
msg = t -> IO Bool
forall t. AssertionPredicable t => t -> IO Bool
assertionPredicate t
predi IO Bool -> (Bool -> Assertion) -> Assertion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
msg

-- | An ad-hoc class used to overload the '@?' operator.
--
-- The only intended instances of this class are @'Bool'@ and @'IO' 'Bool'@.
--
-- You shouldn't need to interact with this class directly.
class AssertionPredicable t
 where assertionPredicate :: t -> IO Bool

instance AssertionPredicable Bool
 where assertionPredicate :: Bool -> IO Bool
assertionPredicate = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return

instance (AssertionPredicable t) => AssertionPredicable (IO t)
 where assertionPredicate :: IO t -> IO Bool
assertionPredicate = (IO t -> (t -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> IO Bool
forall t. AssertionPredicable t => t -> IO Bool
assertionPredicate)


-- | Exception thrown by 'assertFailure' etc.
data HUnitFailure = HUnitFailure (Maybe SrcLoc) String
    deriving (HUnitFailure -> HUnitFailure -> Bool
(HUnitFailure -> HUnitFailure -> Bool)
-> (HUnitFailure -> HUnitFailure -> Bool) -> Eq HUnitFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HUnitFailure -> HUnitFailure -> Bool
$c/= :: HUnitFailure -> HUnitFailure -> Bool
== :: HUnitFailure -> HUnitFailure -> Bool
$c== :: HUnitFailure -> HUnitFailure -> Bool
Eq, Int -> HUnitFailure -> String -> String
[HUnitFailure] -> String -> String
HUnitFailure -> String
(Int -> HUnitFailure -> String -> String)
-> (HUnitFailure -> String)
-> ([HUnitFailure] -> String -> String)
-> Show HUnitFailure
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HUnitFailure] -> String -> String
$cshowList :: [HUnitFailure] -> String -> String
show :: HUnitFailure -> String
$cshow :: HUnitFailure -> String
showsPrec :: Int -> HUnitFailure -> String -> String
$cshowsPrec :: Int -> HUnitFailure -> String -> String
Show, Typeable)
instance E.Exception HUnitFailure

prependLocation :: Maybe SrcLoc -> String -> String
prependLocation :: Maybe SrcLoc -> String -> String
prependLocation Maybe SrcLoc
mbloc String
s =
  case Maybe SrcLoc
mbloc of
    Maybe SrcLoc
Nothing -> String
s
    Just SrcLoc
loc -> SrcLoc -> String
srcLocFile SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

----------------------------------------------------------------------
--                          DEPRECATED CODE
----------------------------------------------------------------------

{-# DEPRECATED assertString "Why not use assertBool instead?" #-}
{-# DEPRECATED Assertable, AssertionPredicate
   "This class or type seems dubious. If you have a good use case for it, please create an issue for tasty. Otherwise, it may be removed in a future version." #-}

-- | Signals an assertion failure if a non-empty message (i.e., a message
-- other than @\"\"@) is passed.
assertString
  :: HasCallStack
  => String    -- ^ The message that is displayed with the assertion failure
  -> Assertion
assertString :: String -> Assertion
assertString String
s = Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
s)

-- Overloaded `assert` Function
-- ----------------------------

-- | Allows the extension of the assertion mechanism.
--
-- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions,
-- there is a fair amount of flexibility of what can be achieved.  As a rule,
-- the resulting @Assertion@ should be the body of a 'TestCase' or part of
-- a @TestCase@; it should not be used to assert multiple, independent
-- conditions.
--
-- If more complex arrangements of assertions are needed, 'Test's and
-- 'Testable' should be used.
class Assertable t
 where assert :: t -> Assertion

instance Assertable ()
 where assert :: () -> Assertion
assert = () -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Assertable Bool
 where assert :: Bool -> Assertion
assert = HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
""

instance (Assertable t) => Assertable (IO t)
 where assert :: IO t -> Assertion
assert = (IO t -> (t -> Assertion) -> Assertion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> Assertion
forall t. Assertable t => t -> Assertion
assert)

instance Assertable String
 where assert :: String -> Assertion
assert = HasCallStack => String -> Assertion
String -> Assertion
assertString


-- Overloaded `assertionPredicate` Function
-- ----------------------------------------

-- | The result of an assertion that hasn't been evaluated yet.
--
-- Most test cases follow the following steps:
--
-- 1. Do some processing or an action.
--
-- 2. Assert certain conditions.
--
-- However, this flow is not always suitable.  @AssertionPredicate@ allows for
-- additional steps to be inserted without the initial action to be affected
-- by side effects.  Additionally, clean-up can be done before the test case
-- has a chance to end.  A potential work flow is:
--
-- 1. Write data to a file.
--
-- 2. Read data from a file, evaluate conditions.
--
-- 3. Clean up the file.
--
-- 4. Assert that the side effects of the read operation meet certain conditions.
--
-- 5. Assert that the conditions evaluated in step 2 are met.
type AssertionPredicate = IO Bool