{-# LANGUAGE CPP #-}
{-|

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(..), AssertStackElem(..), AssertBool(..), boolValue, eitherValue, formatStack

) where

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

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

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

instance AssertM IO where
    genericAssertFailure__ :: Location -> ColorString -> IO a
genericAssertFailure__ Location
loc ColorString
s = FullTestResult -> IO a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (Maybe Location
-> [(Maybe String, Location)]
-> Maybe ColorString
-> Maybe TestResult
-> FullTestResult
FullTestResult (Location -> Maybe Location
forall a. a -> Maybe a
Just Location
loc) [] (ColorString -> Maybe ColorString
forall a. a -> Maybe a
Just ColorString
s) (TestResult -> Maybe TestResult
forall a. a -> Maybe a
Just TestResult
Fail))
    genericSubAssert :: Location -> Maybe String -> IO a -> IO a
genericSubAssert Location
loc Maybe String
mMsg IO a
action = Location -> Maybe String -> IO a -> IO a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
Location -> Maybe String -> m a -> m a
subAssertHTF Location
loc Maybe String
mMsg IO a
action

-- | Stack trace element for generic assertions.
data AssertStackElem
    = AssertStackElem
      { AssertStackElem -> Maybe String
ase_message :: Maybe String
      , AssertStackElem -> Maybe Location
ase_location :: Maybe Location
      }
      deriving (AssertStackElem -> AssertStackElem -> Bool
(AssertStackElem -> AssertStackElem -> Bool)
-> (AssertStackElem -> AssertStackElem -> Bool)
-> Eq AssertStackElem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AssertStackElem -> AssertStackElem -> Bool
$c/= :: AssertStackElem -> AssertStackElem -> Bool
== :: AssertStackElem -> AssertStackElem -> Bool
$c== :: AssertStackElem -> AssertStackElem -> Bool
Eq, Eq AssertStackElem
Eq AssertStackElem
-> (AssertStackElem -> AssertStackElem -> Ordering)
-> (AssertStackElem -> AssertStackElem -> Bool)
-> (AssertStackElem -> AssertStackElem -> Bool)
-> (AssertStackElem -> AssertStackElem -> Bool)
-> (AssertStackElem -> AssertStackElem -> Bool)
-> (AssertStackElem -> AssertStackElem -> AssertStackElem)
-> (AssertStackElem -> AssertStackElem -> AssertStackElem)
-> Ord AssertStackElem
AssertStackElem -> AssertStackElem -> Bool
AssertStackElem -> AssertStackElem -> Ordering
AssertStackElem -> AssertStackElem -> AssertStackElem
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
min :: AssertStackElem -> AssertStackElem -> AssertStackElem
$cmin :: AssertStackElem -> AssertStackElem -> AssertStackElem
max :: AssertStackElem -> AssertStackElem -> AssertStackElem
$cmax :: AssertStackElem -> AssertStackElem -> AssertStackElem
>= :: AssertStackElem -> AssertStackElem -> Bool
$c>= :: AssertStackElem -> AssertStackElem -> Bool
> :: AssertStackElem -> AssertStackElem -> Bool
$c> :: AssertStackElem -> AssertStackElem -> Bool
<= :: AssertStackElem -> AssertStackElem -> Bool
$c<= :: AssertStackElem -> AssertStackElem -> Bool
< :: AssertStackElem -> AssertStackElem -> Bool
$c< :: AssertStackElem -> AssertStackElem -> Bool
compare :: AssertStackElem -> AssertStackElem -> Ordering
$ccompare :: AssertStackElem -> AssertStackElem -> Ordering
$cp1Ord :: Eq AssertStackElem
Ord, Int -> AssertStackElem -> ShowS
[AssertStackElem] -> ShowS
AssertStackElem -> String
(Int -> AssertStackElem -> ShowS)
-> (AssertStackElem -> String)
-> ([AssertStackElem] -> ShowS)
-> Show AssertStackElem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AssertStackElem] -> ShowS
$cshowList :: [AssertStackElem] -> ShowS
show :: AssertStackElem -> String
$cshow :: AssertStackElem -> String
showsPrec :: Int -> AssertStackElem -> ShowS
$cshowsPrec :: Int -> AssertStackElem -> ShowS
Show, ReadPrec [AssertStackElem]
ReadPrec AssertStackElem
Int -> ReadS AssertStackElem
ReadS [AssertStackElem]
(Int -> ReadS AssertStackElem)
-> ReadS [AssertStackElem]
-> ReadPrec AssertStackElem
-> ReadPrec [AssertStackElem]
-> Read AssertStackElem
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AssertStackElem]
$creadListPrec :: ReadPrec [AssertStackElem]
readPrec :: ReadPrec AssertStackElem
$creadPrec :: ReadPrec AssertStackElem
readList :: ReadS [AssertStackElem]
$creadList :: ReadS [AssertStackElem]
readsPrec :: Int -> ReadS AssertStackElem
$creadsPrec :: Int -> ReadS AssertStackElem
Read)

-- | 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 [AssertStackElem]
      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
/= :: AssertBool a -> AssertBool a -> Bool
$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
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
min :: AssertBool a -> AssertBool a -> AssertBool a
$cmin :: forall a. Ord a => AssertBool a -> AssertBool a -> AssertBool a
max :: AssertBool a -> AssertBool a -> AssertBool a
$cmax :: forall a. Ord a => AssertBool a -> AssertBool a -> AssertBool a
>= :: 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
$c< :: forall a. Ord a => AssertBool a -> AssertBool a -> Bool
compare :: AssertBool a -> AssertBool a -> Ordering
$ccompare :: forall a. Ord a => AssertBool a -> AssertBool a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (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
showList :: [AssertBool a] -> ShowS
$cshowList :: forall a. Show a => [AssertBool a] -> ShowS
show :: AssertBool a -> String
$cshow :: forall a. Show a => AssertBool a -> String
showsPrec :: Int -> AssertBool a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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
readListPrec :: ReadPrec [AssertBool a]
$creadListPrec :: forall a. Read a => ReadPrec [AssertBool a]
readPrec :: ReadPrec (AssertBool a)
$creadPrec :: forall a. Read a => ReadPrec (AssertBool a)
readList :: ReadS [AssertBool a]
$creadList :: forall a. Read a => ReadS [AssertBool a]
readsPrec :: Int -> ReadS (AssertBool a)
$creadsPrec :: forall a. Read a => Int -> ReadS (AssertBool a)
Read)

instance Functor AssertBool where
    fmap :: (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 :: a -> AssertBool a
pure  = a -> AssertBool a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: 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 :: a -> AssertBool a
return = a -> AssertBool a
forall a. a -> AssertBool a
AssertOk
    AssertFailed [AssertStackElem]
stack >>= :: AssertBool a -> (a -> AssertBool b) -> AssertBool b
>>= a -> AssertBool b
_ = [AssertStackElem] -> AssertBool b
forall a. [AssertStackElem] -> AssertBool a
AssertFailed [AssertStackElem]
stack
    AssertOk a
x >>= a -> AssertBool b
k = a -> AssertBool b
k a
x
#if !(MIN_VERSION_base(4,13,0))
    fail msg = AssertFailed [AssertStackElem (Just msg) Nothing]
#endif

instance AssertM AssertBool where
    genericAssertFailure__ :: Location -> ColorString -> AssertBool a
genericAssertFailure__ Location
loc ColorString
s =
        [AssertStackElem] -> AssertBool a
forall a. [AssertStackElem] -> AssertBool a
AssertFailed [Maybe String -> Maybe Location -> AssertStackElem
AssertStackElem (String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ColorString -> Bool -> Text
renderColorString ColorString
s Bool
False)) (Location -> Maybe Location
forall a. a -> Maybe a
Just Location
loc)]

    genericSubAssert :: Location -> Maybe String -> AssertBool a -> AssertBool a
genericSubAssert Location
loc Maybe String
mMsg AssertBool a
action =
        case AssertBool a
action of
          AssertOk a
x -> a -> AssertBool a
forall a. a -> AssertBool a
AssertOk a
x
          AssertFailed [AssertStackElem]
stack ->
              [AssertStackElem] -> AssertBool a
forall a. [AssertStackElem] -> AssertBool a
AssertFailed (Maybe String -> Maybe Location -> AssertStackElem
AssertStackElem Maybe String
mMsg (Location -> Maybe Location
forall a. a -> Maybe a
Just Location
loc) AssertStackElem -> [AssertStackElem] -> [AssertStackElem]
forall a. a -> [a] -> [a]
: [AssertStackElem]
stack)

-- | Evaluates a generic assertion to a 'Bool' value.
boolValue :: AssertBool a -> Bool
boolValue :: AssertBool a -> Bool
boolValue AssertBool a
x =
    case AssertBool a
x of
      AssertOk a
_ -> Bool
True
      AssertFailed [AssertStackElem]
_ -> 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 :: 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 [AssertStackElem]
stack -> String -> Either String a
forall a b. a -> Either a b
Left ([AssertStackElem] -> String
formatStack [AssertStackElem]
stack)

-- | Formats a stack trace.
formatStack :: [AssertStackElem] -> String
formatStack :: [AssertStackElem] -> String
formatStack [AssertStackElem]
stack =
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Integer, AssertStackElem) -> String)
-> [(Integer, AssertStackElem)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, AssertStackElem) -> String
forall a. (Ord a, Num a) => (a, AssertStackElem) -> String
formatStackElem ([(Integer, AssertStackElem)] -> [String])
-> [(Integer, AssertStackElem)] -> [String]
forall a b. (a -> b) -> a -> b
$ [Integer] -> [AssertStackElem] -> [(Integer, AssertStackElem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] ([AssertStackElem] -> [(Integer, AssertStackElem)])
-> [AssertStackElem] -> [(Integer, AssertStackElem)]
forall a b. (a -> b) -> a -> b
$ [AssertStackElem] -> [AssertStackElem]
forall a. [a] -> [a]
reverse [AssertStackElem]
stack
    where
      formatStackElem :: (a, AssertStackElem) -> String
formatStackElem (a
pos, AssertStackElem Maybe String
mMsg Maybe Location
mLoc) =
          let floc :: String
floc = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"<unknown location>" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ (Location -> String) -> Maybe Location -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> String
showLoc Maybe Location
mLoc
              fmsg :: String
fmsg = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
s -> String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s) Maybe String
mMsg
              pref :: String
pref = if a
pos a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then String
"  called from " else String
""
          in String
pref String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
floc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fmsg