{-# LANGUAGE CPP #-}
--
-- Copyright (c) 2005-2022   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
--
{-|

This module defines the 'AssertM' monad, which allows you either to run assertions
as ordinary unit tests or to evaluate them as pure functions.

-}
module Test.Framework.AssertM (

    AssertM(..), AssertBool(..), boolValue, eitherValue

) where

import Control.Monad       (liftM, ap)
import GHC.Stack
import qualified Data.Text as T

import Test.Framework.TestInterface
import Test.Framework.Colors

-- | A typeclass for generic assertions.
class Monad m => AssertM m where
    genericAssertFailure :: HasCallStack => ColorString -> m a
    genericSubAssert :: HasCallStack => Maybe String -> m a -> m a

instance AssertM IO where
    genericAssertFailure :: forall a. HasCallStack => ColorString -> IO a
genericAssertFailure ColorString
s =
        FullTestResult -> IO a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (HtfStack -> Maybe ColorString -> Maybe TestResult -> FullTestResult
FullTestResult (CallStack -> HtfStack
mkHtfStack CallStack
HasCallStack => CallStack
callStack) (ColorString -> Maybe ColorString
forall a. a -> Maybe a
Just ColorString
s) (TestResult -> Maybe TestResult
forall a. a -> Maybe a
Just TestResult
Fail))
    genericSubAssert :: forall a. HasCallStack => Maybe String -> IO a -> IO a
genericSubAssert Maybe String
mMsg IO a
action = Maybe String -> IO a -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadBaseControl IO m) =>
Maybe String -> m a -> m a
subAssertHTF Maybe String
mMsg IO a
action

-- | Type for evaluating a generic assertion as a pure function.
data AssertBool a
    -- | Assertion passes successfully and yields the given value.
    = AssertOk a
    -- | Assertion fails with the given stack trace. In the stack trace, the outermost stackframe comes first.
    | AssertFailed HtfStack String
      deriving (AssertBool a -> AssertBool a -> Bool
(AssertBool a -> AssertBool a -> Bool)
-> (AssertBool a -> AssertBool a -> Bool) -> Eq (AssertBool a)
forall a. Eq a => AssertBool a -> AssertBool a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => AssertBool a -> AssertBool a -> Bool
== :: AssertBool a -> AssertBool a -> Bool
$c/= :: forall a. Eq a => AssertBool a -> AssertBool a -> Bool
/= :: AssertBool a -> AssertBool a -> Bool
Eq, Eq (AssertBool a)
Eq (AssertBool a) =>
(AssertBool a -> AssertBool a -> Ordering)
-> (AssertBool a -> AssertBool a -> Bool)
-> (AssertBool a -> AssertBool a -> Bool)
-> (AssertBool a -> AssertBool a -> Bool)
-> (AssertBool a -> AssertBool a -> Bool)
-> (AssertBool a -> AssertBool a -> AssertBool a)
-> (AssertBool a -> AssertBool a -> AssertBool a)
-> Ord (AssertBool a)
AssertBool a -> AssertBool a -> Bool
AssertBool a -> AssertBool a -> Ordering
AssertBool a -> AssertBool a -> AssertBool a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (AssertBool a)
forall a. Ord a => AssertBool a -> AssertBool a -> Bool
forall a. Ord a => AssertBool a -> AssertBool a -> Ordering
forall a. Ord a => AssertBool a -> AssertBool a -> AssertBool a
$ccompare :: forall a. Ord a => AssertBool a -> AssertBool a -> Ordering
compare :: AssertBool a -> AssertBool a -> Ordering
$c< :: forall a. Ord a => AssertBool a -> AssertBool a -> Bool
< :: AssertBool a -> AssertBool a -> Bool
$c<= :: forall a. Ord a => AssertBool a -> AssertBool a -> Bool
<= :: AssertBool a -> AssertBool a -> Bool
$c> :: forall a. Ord a => AssertBool a -> AssertBool a -> Bool
> :: AssertBool a -> AssertBool a -> Bool
$c>= :: forall a. Ord a => AssertBool a -> AssertBool a -> Bool
>= :: AssertBool a -> AssertBool a -> Bool
$cmax :: forall a. Ord a => AssertBool a -> AssertBool a -> AssertBool a
max :: AssertBool a -> AssertBool a -> AssertBool a
$cmin :: forall a. Ord a => AssertBool a -> AssertBool a -> AssertBool a
min :: AssertBool a -> AssertBool a -> AssertBool a
Ord, Int -> AssertBool a -> ShowS
[AssertBool a] -> ShowS
AssertBool a -> String
(Int -> AssertBool a -> ShowS)
-> (AssertBool a -> String)
-> ([AssertBool a] -> ShowS)
-> Show (AssertBool a)
forall a. Show a => Int -> AssertBool a -> ShowS
forall a. Show a => [AssertBool a] -> ShowS
forall a. Show a => AssertBool a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AssertBool a -> ShowS
showsPrec :: Int -> AssertBool a -> ShowS
$cshow :: forall a. Show a => AssertBool a -> String
show :: AssertBool a -> String
$cshowList :: forall a. Show a => [AssertBool a] -> ShowS
showList :: [AssertBool a] -> ShowS
Show, ReadPrec [AssertBool a]
ReadPrec (AssertBool a)
Int -> ReadS (AssertBool a)
ReadS [AssertBool a]
(Int -> ReadS (AssertBool a))
-> ReadS [AssertBool a]
-> ReadPrec (AssertBool a)
-> ReadPrec [AssertBool a]
-> Read (AssertBool a)
forall a. Read a => ReadPrec [AssertBool a]
forall a. Read a => ReadPrec (AssertBool a)
forall a. Read a => Int -> ReadS (AssertBool a)
forall a. Read a => ReadS [AssertBool a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (AssertBool a)
readsPrec :: Int -> ReadS (AssertBool a)
$creadList :: forall a. Read a => ReadS [AssertBool a]
readList :: ReadS [AssertBool a]
$creadPrec :: forall a. Read a => ReadPrec (AssertBool a)
readPrec :: ReadPrec (AssertBool a)
$creadListPrec :: forall a. Read a => ReadPrec [AssertBool a]
readListPrec :: ReadPrec [AssertBool a]
Read)

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

instance Applicative AssertBool where
    pure :: forall a. a -> AssertBool a
pure  = a -> AssertBool a
forall a. a -> AssertBool a
AssertOk
    <*> :: forall a b. AssertBool (a -> b) -> AssertBool a -> AssertBool b
(<*>) = AssertBool (a -> b) -> AssertBool a -> AssertBool b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad AssertBool where
    return :: forall a. a -> AssertBool a
return = a -> AssertBool a
forall a. a -> AssertBool a
AssertOk
    AssertFailed HtfStack
stack String
msg >>= :: forall a b. AssertBool a -> (a -> AssertBool b) -> AssertBool b
>>= a -> AssertBool b
_ = HtfStack -> String -> AssertBool b
forall a. HtfStack -> String -> AssertBool a
AssertFailed HtfStack
stack String
msg
    AssertOk a
x >>= a -> AssertBool b
k = a -> AssertBool b
k a
x
#if !(MIN_VERSION_base(4,13,0))
    fail msg = AssertFailed emptyHtfStack msg
#endif

instance AssertM AssertBool where
    genericAssertFailure :: forall a. HasCallStack => ColorString -> AssertBool a
genericAssertFailure ColorString
s =
        HtfStack -> String -> AssertBool a
forall a. HtfStack -> String -> AssertBool a
AssertFailed (CallStack -> HtfStack
mkHtfStack CallStack
HasCallStack => CallStack
callStack) (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ColorString -> Bool -> Text
renderColorString ColorString
s Bool
False)
    genericSubAssert :: forall a.
HasCallStack =>
Maybe String -> AssertBool a -> AssertBool a
genericSubAssert Maybe String
subMsg AssertBool a
action =
        case AssertBool a
action of
          AssertOk a
x -> a -> AssertBool a
forall a. a -> AssertBool a
AssertOk a
x
          AssertFailed HtfStack
stack String
msg ->
              let ghcStack :: CallStack
ghcStack = CallStack
HasCallStack => CallStack
callStack
              in HtfStack -> String -> AssertBool a
forall a. HtfStack -> String -> AssertBool a
AssertFailed (CallStack -> HtfStack -> Maybe String -> HtfStack
addCallerToSubAssertStack CallStack
ghcStack HtfStack
stack Maybe String
subMsg) String
msg

-- | Evaluates a generic assertion to a 'Bool' value.
boolValue :: AssertBool a -> Bool
boolValue :: forall a. AssertBool a -> Bool
boolValue AssertBool a
x =
    case AssertBool a
x of
      AssertOk a
_ -> Bool
True
      AssertFailed HtfStack
_ String
_ -> Bool
False

-- | Evaluates a generic assertion to an 'Either' value. The result
--   is @Right x@ if the assertion passes and yields value @x@, otherwise
--   the result is @Left err@, where @err@ is an error message.
eitherValue :: AssertBool a -> Either String a
eitherValue :: forall a. AssertBool a -> Either String a
eitherValue AssertBool a
x =
    case AssertBool a
x of
      AssertOk a
z -> a -> Either String a
forall a b. b -> Either a b
Right a
z
      AssertFailed HtfStack
stack String
msg -> String -> Either String a
forall a b. a -> Either a b
Left (String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HtfStack -> String
formatHtfStack HtfStack
stack)