Add MonadFail instances for internal monads

Fixes #110

dejafu/CHANGELOG.markdown

@@ -7,6 +7,18 @@ This project is versioned according to the [Package Versioning Policy](https://p
 *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
 -------
 

dejafu/Test/DejaFu/Common.hs

@@ -58,11 +58,12 @@ module Test.DejaFu.Common
   , MemType(..)
 
   -- * Miscellaneous
+  , MonadFailException(..)
   , runRefCont
   ) where
 
 import           Control.DeepSeq    (NFData(..))
-import           Control.Exception  (MaskingState(..))
+import           Control.Exception  (Exception(..), MaskingState(..))
 import           Control.Monad.Ref  (MonadRef(..))
 import           Data.List          (intercalate, nub, sort)
 import           Data.List.NonEmpty (NonEmpty)
@@ -866,6 +867,12 @@ instance NFData MemType where
 -------------------------------------------------------------------------------
 -- 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,
 -- returning the computation and the reference.  Using the reference
 -- is non-blocking, it is up to you to ensure you wait sufficiently.

dejafu/Test/DejaFu/Conc/Internal/Common.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -7,7 +8,7 @@
 -- License     : MIT
 -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
 -- Stability   : experimental
--- Portability : ExistentialQuantification, RankNTypes
+-- Portability : CPP, ExistentialQuantification, RankNTypes
 --
 -- Common types and utility functions for deterministic execution of
 -- '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.STM    (STMLike)
 
+#if MIN_VERSION_base(4,9,0)
+import qualified Control.Monad.Fail as Fail
+#endif
+
 --------------------------------------------------------------------------------
 -- * The @Conc@ Monad
 
@@ -43,6 +48,14 @@ 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 (\_ -> AThrow (MonadFailException e))
+
 -- | The concurrent variable type used with the 'Conc' monad. One
 -- 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@

dejafu/Test/DejaFu/STM.hs

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

dejafu/Test/DejaFu/STM/Internal.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
@@ -8,7 +9,7 @@
 -- License     : MIT
 -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
 -- Stability   : experimental
--- Portability : ExistentialQuantification, RankNTypes
+-- Portability : CPP, ExistentialQuantification, MultiParamTypeClasses, RankNTypes
 --
 -- 'MonadSTM' testing implementation, internal types and
 -- 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.Exception  (Exception, SomeException, fromException,
                                      toException)
-import           Control.Monad.Cont (Cont, runCont)
 import           Control.Monad.Ref  (MonadRef, newRef, readRef, writeRef)
 import           Data.List          (nub)
 
 import           Test.DejaFu.Common
 
+#if MIN_VERSION_base(4,9,0)
+import qualified Control.Monad.Fail as Fail
+#endif
+
 --------------------------------------------------------------------------------
 -- The @STMLike@ monad
 
 -- | The underlying monad is based on continuations over primitive
 -- 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