Rename Conc to ConcT and turn into a MonadTrans.

Closes #70.

dejafu-tests/Cases/MultiThreaded.hs

@@ -14,7 +14,7 @@ import Test.HUnit.DejaFu (testDejafuWay)
 
 import Control.Concurrent.Classy
 import Control.Monad.STM.Class
-import Test.DejaFu.Conc (Conc, ConcST, subconcurrency)
+import Test.DejaFu.Conc (ConcT, ConcST, subconcurrency)
 
 import Utils
 
@@ -286,7 +286,7 @@ schedDaemon = do
 -- Subconcurrency
 
 -- | Subcomputation deadlocks sometimes.
-scDeadlock1 :: Monad n => Conc n r (Either Failure ())
+scDeadlock1 :: Monad n => ConcT r n (Either Failure ())
 scDeadlock1 = do
   var <- newEmptyMVar
   subconcurrency $ do
@@ -295,7 +295,7 @@ scDeadlock1 = do
 
 -- | Subcomputation deadlocks sometimes, and action after it still
 -- happens.
-scDeadlock2 :: Monad n => Conc n r (Either Failure (), ())
+scDeadlock2 :: Monad n => ConcT r n (Either Failure (), ())
 scDeadlock2 = do
   var <- newEmptyMVar
   res <- subconcurrency $ do
@@ -304,7 +304,7 @@ scDeadlock2 = do
   (,) <$> pure res <*> readMVar var
 
 -- | Subcomputation successfully completes.
-scSuccess :: Monad n => Conc n r (Either Failure ())
+scSuccess :: Monad n => ConcT r n (Either Failure ())
 scSuccess = do
   var <- newMVar ()
   subconcurrency $ do
@@ -313,7 +313,7 @@ scSuccess = do
     takeMVar out
 
 -- | Illegal usage
-scIllegal :: Monad n => Conc n r ()
+scIllegal :: Monad n => ConcT r n ()
 scIllegal = do
   var <- newEmptyMVar
   void . fork $ readMVar var
@@ -321,7 +321,7 @@ scIllegal = do
 
 -- | Test case from issue 71. This won't fail if the bug is
 -- reintroduced, it will just hang.
-scIssue71 :: Monad n => Conc n r ()
+scIssue71 :: Monad n => ConcT r n ()
 scIssue71 = do
   let ma ||| mb = do { j1 <- spawn ma; j2 <- spawn mb; takeMVar j1; takeMVar j2; pure () }
   s <- newEmptyMVar

dejafu-tests/Cases/SingleThreaded.hs

@@ -12,7 +12,7 @@ import Test.HUnit (test)
 import Test.HUnit.DejaFu (testDejafu)
 
 import Control.Concurrent.Classy
-import Test.DejaFu.Conc (Conc, subconcurrency)
+import Test.DejaFu.Conc (ConcT, subconcurrency)
 
 import Utils
 
@@ -288,17 +288,17 @@ capsSet = do
 -- Subconcurrency
 
 -- | Subcomputation deadlocks.
-scDeadlock1 :: Monad n => Conc n r (Either Failure ())
+scDeadlock1 :: Monad n => ConcT r n (Either Failure ())
 scDeadlock1 = subconcurrency (newEmptyMVar >>= readMVar)
 
 -- | Subcomputation deadlocks, and action after it still happens.
-scDeadlock2 :: Monad n => Conc n r (Either Failure (), ())
+scDeadlock2 :: Monad n => ConcT r n (Either Failure (), ())
 scDeadlock2 = do
   var <- newMVar ()
   (,) <$> subconcurrency (putMVar var ()) <*> readMVar var
 
 -- | Subcomputation successfully completes.
-scSuccess :: Monad n => Conc n r (Either Failure ())
+scSuccess :: Monad n => ConcT r n (Either Failure ())
 scSuccess = do
   var <- newMVar ()
   subconcurrency (takeMVar var)

dejafu/CHANGELOG.markdown

@@ -10,6 +10,11 @@ This project is versioned according to the [Package Versioning Policy](https://p
 unreleased
 ----------
 
+### Test.DejaFu.Conc
+
+- The `Conc n r a` type is now `ConcT r n a`, and has been given a `MonadTrans` instance. Uses of
+  `lift` appear in the execution trace in the same way as `liftBase` and `liftIO`.
+
 ### Test.DejaFu.SCT
 
 - `Way` is now a GADT, no longer taking a type parameter. This greatly improves type inference when

dejafu/Test/DejaFu.hs

@@ -482,14 +482,14 @@ runTestWay way memtype predicate conc =
 --
 -- @since 0.4.0.0
 runTestM :: MonadRef r n
-         => Predicate a -> Conc n r a -> n (Result a)
+         => Predicate a -> ConcT r n a -> n (Result a)
 runTestM = runTestWayM defaultWay defaultMemType
 
 -- | Monad-polymorphic variant of 'runTest''.
 --
 -- @since unreleased
 runTestWayM :: MonadRef r n
-            => Way -> MemType -> Predicate a -> Conc n r a -> n (Result a)
+            => Way -> MemType -> Predicate a -> ConcT r n a -> n (Result a)
 runTestWayM way memtype predicate conc =
   predicate <$> runSCT way memtype conc
 

dejafu/Test/DejaFu/Conc.hs

@@ -19,8 +19,8 @@
 -- out to the supplied scheduler after each step to determine which
 -- thread runs next.
 module Test.DejaFu.Conc
-  ( -- * The @Conc@ Monad
-    Conc
+  ( -- * The @ConcT@ monad transformer
+    ConcT
   , ConcST
   , ConcIO
 
@@ -53,6 +53,7 @@ import qualified Control.Monad.IO.Class           as IO
 import           Control.Monad.Ref                (MonadRef)
 import qualified Control.Monad.Ref                as Re
 import           Control.Monad.ST                 (ST)
+import           Control.Monad.Trans.Class        (MonadTrans(..))
 import qualified Data.Foldable                    as F
 import           Data.IORef                       (IORef)
 import           Data.STRef                       (STRef)
@@ -64,24 +65,24 @@ import           Test.DejaFu.Conc.Internal
 import           Test.DejaFu.Conc.Internal.Common
 import           Test.DejaFu.STM
 
--- | @since 0.4.0.0
-newtype Conc n r a = C { unC :: M n r a } deriving (Functor, Applicative, Monad)
+-- | @since unreleased
+newtype ConcT r n a = C { unC :: M n r a } deriving (Functor, Applicative, Monad)
 
 -- | A 'MonadConc' implementation using @ST@, this should be preferred
 -- if you do not need 'liftIO'.
 --
 -- @since 0.4.0.0
-type ConcST t = Conc (ST t) (STRef t)
+type ConcST t = ConcT (STRef t) (ST t)
 
 -- | A 'MonadConc' implementation using @IO@.
 --
 -- @since 0.4.0.0
-type ConcIO = Conc IO IORef
+type ConcIO = ConcT IORef IO
 
-toConc :: ((a -> Action n r) -> Action n r) -> Conc n r a
+toConc :: ((a -> Action n r) -> Action n r) -> ConcT r n a
 toConc = C . cont
 
-wrap :: (M n r a -> M n r a) -> Conc n r a -> Conc n r a
+wrap :: (M n r a -> M n r a) -> ConcT r n a -> ConcT r n a
 wrap f = C . f . unC
 
 instance IO.MonadIO ConcIO where
@@ -90,8 +91,7 @@ instance IO.MonadIO ConcIO where
 instance Ba.MonadBase IO ConcIO where
   liftBase = IO.liftIO
 
--- | @since 0.5.1.3
-instance Re.MonadRef (CRef r) (Conc n r) where
+instance Re.MonadRef (CRef r) (ConcT r n) where
   newRef a = toConc (ANewCRef "" a)
 
   readRef ref = toConc (AReadCRef ref)
@@ -100,25 +100,28 @@ instance Re.MonadRef (CRef r) (Conc n r) where
 
   modifyRef ref f = toConc (AModCRef ref (\a -> (f a, ())))
 
-instance Re.MonadAtomicRef (CRef r) (Conc n r) where
+instance Re.MonadAtomicRef (CRef r) (ConcT r n) where
   atomicModifyRef ref f = toConc (AModCRef ref f)
 
-instance Ca.MonadCatch (Conc n r) where
+instance MonadTrans (ConcT r) where
+  lift ma = toConc (\c -> ALift (fmap c ma))
+
+instance Ca.MonadCatch (ConcT r n) where
   catch ma h = toConc (ACatching (unC . h) (unC ma))
 
-instance Ca.MonadThrow (Conc n r) where
+instance Ca.MonadThrow (ConcT r n) where
   throwM e = toConc (\_ -> AThrow e)
 
-instance Ca.MonadMask (Conc n r) where
+instance Ca.MonadMask (ConcT r n) where
   mask                mb = toConc (AMasking MaskedInterruptible   (\f -> unC $ mb $ wrap f))
   uninterruptibleMask mb = toConc (AMasking MaskedUninterruptible (\f -> unC $ mb $ wrap f))
 
-instance Monad n => C.MonadConc (Conc n r) where
-  type MVar     (Conc n r) = MVar r
-  type CRef     (Conc n r) = CRef r
-  type Ticket   (Conc n r) = Ticket
-  type STM      (Conc n r) = STMLike n r
-  type ThreadId (Conc n r) = ThreadId
+instance Monad n => C.MonadConc (ConcT r n) where
+  type MVar     (ConcT r n) = MVar r
+  type CRef     (ConcT r n) = CRef r
+  type Ticket   (ConcT r n) = Ticket
+  type STM      (ConcT r n) = STMLike n r
+  type ThreadId (ConcT r n) = ThreadId
 
   -- ----------
 
@@ -192,7 +195,7 @@ runConcurrent :: MonadRef r n
               => Scheduler s
               -> MemType
               -> s
-              -> Conc n r a
+              -> ConcT r n a
               -> n (Either Failure a, s, Trace)
 runConcurrent sched memtype s ma = do
   (res, s', trace, _) <- runConcurrency sched memtype s 2 (unC ma)
@@ -205,6 +208,6 @@ runConcurrent sched memtype s ma = do
 -- of these conditions will result in the computation failing with
 -- @IllegalSubconcurrency@.
 --
--- @since 0.5.0.0
-subconcurrency :: Conc n r a -> Conc n r (Either Failure a)
+-- @since unreleased
+subconcurrency :: ConcT r n a -> ConcT r n (Either Failure a)
 subconcurrency ma = toConc (ASub (unC ma))

dejafu/Test/DejaFu/SCT.hs

@@ -133,7 +133,7 @@ runSCT :: MonadRef r n
   -- ^ How to run the concurrent program.
   -> MemType
   -- ^ The memory model to use for non-synchronised @CRef@ operations.
-  -> Conc n r a
+  -> ConcT r n a
   -- ^ The computation to run many times.
   -> n [(Either Failure a, Trace)]
 runSCT (Systematically cb) memtype = sctBound memtype cb
@@ -146,7 +146,7 @@ runSCT (Randomly g lim)    memtype = sctRandom memtype g lim
 --
 -- @since unreleased
 runSCT' :: (MonadRef r n, NFData a)
-  => Way -> MemType -> Conc n r a -> n [(Either Failure a, Trace)]
+  => Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]
 runSCT' way memtype conc = do
   res <- runSCT way memtype conc
   rnf res `seq` pure res
@@ -159,7 +159,7 @@ resultsSet :: (MonadRef r n, Ord a)
   -- ^ How to run the concurrent program.
   -> MemType
   -- ^ The memory model to use for non-synchronised @CRef@ operations.
-  -> Conc n r a
+  -> ConcT r n a
   -- ^ The computation to run many times.
   -> n (Set (Either Failure a))
 resultsSet way memtype conc =
@@ -172,7 +172,7 @@ resultsSet way memtype conc =
 --
 -- @since unreleased
 resultsSet' :: (MonadRef r n, Ord a, NFData a)
-  => Way -> MemType -> Conc n r a -> n (Set (Either Failure a))
+  => Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))
 resultsSet' way memtype conc = do
   res <- resultsSet' way memtype conc
   rnf res `seq` pure res
@@ -244,7 +244,7 @@ sctPreBound :: MonadRef r n
   -> PreemptionBound
   -- ^ The maximum number of pre-emptions to allow in a single
   -- execution
-  -> Conc n r a
+  -> ConcT r n a
   -- ^ The computation to run many times
   -> n [(Either Failure a, Trace)]
 sctPreBound memtype pb = sctBound memtype $ Bounds (Just pb) Nothing Nothing
@@ -295,7 +295,7 @@ sctFairBound :: MonadRef r n
   -> FairBound
   -- ^ The maximum difference between the number of yield operations
   -- performed by different threads.
-  -> Conc n r a
+  -> ConcT r n a
   -- ^ The computation to run many times
   -> n [(Either Failure a, Trace)]
 sctFairBound memtype fb = sctBound memtype $ Bounds Nothing (Just fb) Nothing
@@ -332,7 +332,7 @@ sctLengthBound :: MonadRef r n
   -> LengthBound
   -- ^ The maximum length of a schedule, in terms of primitive
   -- actions.
-  -> Conc n r a
+  -> ConcT r n a
   -- ^ The computation to run many times
   -> n [(Either Failure a, Trace)]
 sctLengthBound memtype lb = sctBound memtype $ Bounds Nothing Nothing (Just lb)
@@ -367,7 +367,7 @@ sctBound :: MonadRef r n
   -- ^ The memory model to use for non-synchronised @CRef@ operations.
   -> Bounds
   -- ^ The combined bounds.
-  -> Conc n r a
+  -> ConcT r n a
   -- ^ The computation to run many times
   -> n [(Either Failure a, Trace)]
 sctBound memtype cb conc = go initialState where
@@ -416,7 +416,7 @@ sctRandom :: (MonadRef r n, RandomGen g)
   -- ^ The random number generator.
   -> Int
   -- ^ The number of executions to perform.
-  -> Conc n r a
+  -> ConcT r n a
   -- ^ The computation to run many times.
   -> n [(Either Failure a, Trace)]
 sctRandom memtype g0 lim0 conc = go g0 lim0 where