AssertM.hs

{-# 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 s =
        failHTF (FullTestResult (mkHtfStack callStack) (Just s) (Just Fail))
    genericSubAssert mMsg action = subAssertHTF mMsg 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 (Eq, Ord, Show, Read)

instance Functor AssertBool where
    fmap = liftM

instance Applicative AssertBool where
    pure  = AssertOk
    (<*>) = ap

instance Monad AssertBool where
    return = AssertOk
    AssertFailed stack msg >>= _ = AssertFailed stack msg
    AssertOk x >>= k = k x
#if !(MIN_VERSION_base(4,13,0))
    fail msg = AssertFailed emptyHtfStack msg
#endif

instance AssertM AssertBool where
    genericAssertFailure s =
        AssertFailed (mkHtfStack callStack) (T.unpack $ renderColorString s False)
    genericSubAssert subMsg action =
        case action of
          AssertOk x -> AssertOk x
          AssertFailed stack msg ->
              let ghcStack = callStack
              in AssertFailed (addCallerToSubAssertStack ghcStack stack subMsg) msg

-- | Evaluates a generic assertion to a 'Bool' value.
boolValue :: AssertBool a -> Bool
boolValue x =
    case x of
      AssertOk _ -> True
      AssertFailed _ _ -> 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 x =
    case x of
      AssertOk z -> Right z
      AssertFailed stack msg -> Left (msg ++ "\n" ++ formatHtfStack stack)