Add MonadFail instances for internal monads

Fixes #110
This commit is contained in:
Michael Walker 2017-08-21 16:17:58 +01:00
parent 91fa969fc2
commit 2d4e28e308
5 changed files with 71 additions and 6 deletions

View File

@ -7,6 +7,18 @@ This project is versioned according to the [Package Versioning Policy](https://p
*de facto* standard Haskell versioning scheme. *de facto* standard Haskell versioning scheme.
unreleased
----------
### Miscellaneous
- Errors thrown with `Control.Monad.fail` no longer terminate testing, and are now correctly treated
as asynchronous exceptions.
---------------------------------------------------------------------------------------------------
0.7.1.1 0.7.1.1
------- -------

View File

@ -58,11 +58,12 @@ module Test.DejaFu.Common
, MemType(..) , MemType(..)
-- * Miscellaneous -- * Miscellaneous
, MonadFailException(..)
, runRefCont , runRefCont
) where ) where
import Control.DeepSeq (NFData(..)) import Control.DeepSeq (NFData(..))
import Control.Exception (MaskingState(..)) import Control.Exception (Exception(..), MaskingState(..))
import Control.Monad.Ref (MonadRef(..)) import Control.Monad.Ref (MonadRef(..))
import Data.List (intercalate, nub, sort) import Data.List (intercalate, nub, sort)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
@ -866,6 +867,12 @@ instance NFData MemType where
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Miscellaneous -- Miscellaneous
-- | An exception for errors in testing caused by use of 'fail'.
newtype MonadFailException = MonadFailException String
deriving Show
instance Exception MonadFailException
-- | Run with a continuation that writes its value into a reference, -- | Run with a continuation that writes its value into a reference,
-- returning the computation and the reference. Using the reference -- returning the computation and the reference. Using the reference
-- is non-blocking, it is up to you to ensure you wait sufficiently. -- is non-blocking, it is up to you to ensure you wait sufficiently.

View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
@ -7,7 +8,7 @@
-- License : MIT -- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk> -- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental -- Stability : experimental
-- Portability : ExistentialQuantification, RankNTypes -- Portability : CPP, ExistentialQuantification, RankNTypes
-- --
-- Common types and utility functions for deterministic execution of -- Common types and utility functions for deterministic execution of
-- 'MonadConc' implementations. This module is NOT considered to form -- 'MonadConc' implementations. This module is NOT considered to form
@ -19,6 +20,10 @@ import Data.Map.Strict (Map)
import Test.DejaFu.Common import Test.DejaFu.Common
import Test.DejaFu.STM (STMLike) import Test.DejaFu.STM (STMLike)
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- * The @Conc@ Monad -- * The @Conc@ Monad
@ -43,6 +48,14 @@ instance Monad (M n r) where
return = pure return = pure
m >>= k = M $ \c -> runM m (\x -> runM (k x) c) m >>= k = M $ \c -> runM m (\x -> runM (k x) c)
#if MIN_VERSION_base(4,9,0)
fail = Fail.fail
-- | @since unreleased
instance Fail.MonadFail (M n r) where
#endif
fail e = cont (\_ -> AThrow (MonadFailException e))
-- | The concurrent variable type used with the 'Conc' monad. One -- | The concurrent variable type used with the 'Conc' monad. One
-- notable difference between these and 'MVar's is that 'MVar's are -- notable difference between these and 'MVar's is that 'MVar's are
-- single-wakeup, and wake up in a FIFO order. Writing to a @MVar@ -- single-wakeup, and wake up in a FIFO order. Writing to a @MVar@

View File

@ -28,7 +28,6 @@ module Test.DejaFu.STM
import Control.Monad (unless) import Control.Monad (unless)
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import Control.Monad.Cont (cont)
import Control.Monad.Ref (MonadRef) import Control.Monad.Ref (MonadRef)
import Control.Monad.ST (ST) import Control.Monad.ST (ST)
import Data.IORef (IORef) import Data.IORef (IORef)

View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
@ -8,7 +9,7 @@
-- License : MIT -- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk> -- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental -- Stability : experimental
-- Portability : ExistentialQuantification, RankNTypes -- Portability : CPP, ExistentialQuantification, MultiParamTypeClasses, RankNTypes
-- --
-- 'MonadSTM' testing implementation, internal types and -- 'MonadSTM' testing implementation, internal types and
-- definitions. This module is NOT considered to form part of the -- definitions. This module is NOT considered to form part of the
@ -18,18 +19,51 @@ module Test.DejaFu.STM.Internal where
import Control.DeepSeq (NFData(..)) import Control.DeepSeq (NFData(..))
import Control.Exception (Exception, SomeException, fromException, import Control.Exception (Exception, SomeException, fromException,
toException) toException)
import Control.Monad.Cont (Cont, runCont)
import Control.Monad.Ref (MonadRef, newRef, readRef, writeRef) import Control.Monad.Ref (MonadRef, newRef, readRef, writeRef)
import Data.List (nub) import Data.List (nub)
import Test.DejaFu.Common import Test.DejaFu.Common
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- The @STMLike@ monad -- The @STMLike@ monad
-- | The underlying monad is based on continuations over primitive -- | The underlying monad is based on continuations over primitive
-- actions. -- actions.
type M n r a = Cont (STMAction n r) a --
-- This is not @Cont@ because we want to give it a custom @MonadFail@
-- instance.
newtype M n r a = M { runM :: (a -> STMAction n r) -> STMAction n r }
instance Functor (M n r) where
fmap f m = M $ \ c -> runM m (c . f)
instance Applicative (M n r) where
pure x = M $ \c -> c x
f <*> v = M $ \c -> runM f (\g -> runM v (c . g))
instance Monad (M n r) where
return = pure
m >>= k = M $ \c -> runM m (\x -> runM (k x) c)
#if MIN_VERSION_base(4,9,0)
fail = Fail.fail
-- | @since unreleased
instance Fail.MonadFail (M n r) where
#endif
fail e = cont (\_ -> SThrow (MonadFailException e))
-- | Construct a continuation-passing operation from a function.
cont :: ((a -> STMAction n r) -> STMAction n r) -> M n r a
cont = M
-- | Run a CPS computation with the given final computation.
runCont :: M n r a -> (a -> STMAction n r) -> STMAction n r
runCont = runM
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- * Primitive actions -- * Primitive actions