HUnit.hs

module Core.Test.HUnit
  ( tryTest
  , denoteFailIn
  , denoteFail
  ) where

import Test.HUnit.Lang
import Data.Maybe
import Control.Exception

-- | Will return 'Nothing' if an exception was raised.
tryTest :: IO a -> IO (Maybe a)
tryTest action = do
  res <- try action
  case res of
       Left HUnitFailure{} -> pure Nothing
       Right val -> pure $ Just val

-- | If a failure occurs, denotes that it occurred for "in" the given label.
denoteFailIn :: String -> IO a -> IO a
denoteFailIn label = denoteFail $ "in " ++ label ++ ": "

-- | If a failure occurs, prepends the given string to the error
-- message.
denoteFail :: String -> IO a -> IO a
denoteFail pre test = test `catch` rethrowWithPrefix pre

-- | Prepends the given string to the error message.
rethrowWithPrefix :: String -> HUnitFailure -> IO a
rethrowWithPrefix pre = throw . addPrefixToFailure pre

addPrefixToFailure :: String -> HUnitFailure -> HUnitFailure
addPrefixToFailure pre (HUnitFailure srcLoc reason)
  = HUnitFailure srcLoc $ addPrefixToReason pre reason

addPrefixToReason :: String -> FailureReason -> FailureReason
addPrefixToReason pre (Reason msg) = Reason $ addPrefixToMsg pre msg
addPrefixToReason pre (ExpectedButGot extraMsg expected got)
  = ExpectedButGot (addPrefixToExtraMsg pre extraMsg) expected got

addPrefixToExtraMsg :: String -> Maybe String -> Maybe String
addPrefixToExtraMsg pre = Just . addPrefixToMsg pre . fromMaybe ""

addPrefixToMsg :: String -> String -> String
addPrefixToMsg pre msg = pre ++ msg