Assertions with an optional descriptive message, with both monadic and non-monadic variants

Assert.hs

{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverlappingInstances #-}

module Assert where

import Control.Exception

import Data.Typeable

data AssertionFailure = AssertionFailure (Maybe String) deriving Typeable

instance Exception AssertionFailure

instance Show AssertionFailure where
  show (AssertionFailure Nothing) = "Assertion failed"
  show (AssertionFailure (Just msg)) = "Assertion failed: " ++ msg

class AssertResult ar where assert :: Bool -> ar

instance AssertResult (a -> a) where
  assert True = id
  assert False = throw $ AssertionFailure Nothing

instance AssertResult (String -> a -> a) where
  assert True _ = id
  assert False msg = throw $ AssertionFailure $ Just msg

instance Monad m => AssertResult (m a) where
  assert True = return undefined
  assert False = throw $ AssertionFailure Nothing

instance Monad m => AssertResult (String -> m a) where
  assert True _ = return undefined
  assert False msg = throw $ AssertionFailure $ Just msg