{-# LANGUAGE CPP #-}
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
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
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)
data AssertBool a
= AssertOk a
| 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)
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
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)
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