module Test.DejaFu.Conc
(
ConcT
, ConcST
, ConcIO
, Failure(..)
, MemType(..)
, runConcurrent
, subconcurrency
, Trace
, Decision(..)
, ThreadId(..)
, ThreadAction(..)
, Lookahead(..)
, MVarId
, CRefId
, MaskingState(..)
, showTrace
, showFail
, module Test.DejaFu.Schedule
) where
import Control.Exception (MaskingState(..))
import qualified Control.Monad.Base as Ba
import qualified Control.Monad.Catch as Ca
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)
import Test.DejaFu.Schedule
import qualified Control.Monad.Conc.Class as C
import Test.DejaFu.Common
import Test.DejaFu.Conc.Internal
import Test.DejaFu.Conc.Internal.Common
import Test.DejaFu.STM
newtype ConcT r n a = C { unC :: M n r a } deriving (Functor, Applicative, Monad)
type ConcST t = ConcT (STRef t) (ST t)
type ConcIO = ConcT IORef IO
toConc :: ((a -> Action n r) -> Action n r) -> ConcT r n a
toConc = C . cont
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
liftIO ma = toConc (\c -> ALift (fmap c ma))
instance Ba.MonadBase IO ConcIO where
liftBase = IO.liftIO
instance Re.MonadRef (CRef r) (ConcT r n) where
newRef a = toConc (ANewCRef "" a)
readRef ref = toConc (AReadCRef ref)
writeRef ref a = toConc (\c -> AWriteCRef ref a (c ()))
modifyRef ref f = toConc (AModCRef ref (\a -> (f a, ())))
instance Re.MonadAtomicRef (CRef r) (ConcT r n) where
atomicModifyRef ref f = toConc (AModCRef ref f)
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 (ConcT r n) where
throwM e = toConc (\_ -> AThrow e)
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 (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
forkWithUnmaskN n ma = toConc (AFork n (\umask -> runCont (unC $ ma $ wrap umask) (\_ -> AStop (pure ()))))
forkOnWithUnmaskN n _ = C.forkWithUnmaskN n
getNumCapabilities = toConc AGetNumCapabilities
setNumCapabilities caps = toConc (\c -> ASetNumCapabilities caps (c ()))
myThreadId = toConc AMyTId
yield = toConc (\c -> AYield (c ()))
newCRefN n a = toConc (ANewCRef n a)
readCRef ref = toConc (AReadCRef ref)
readForCAS ref = toConc (AReadCRefCas ref)
peekTicket' _ = _ticketVal
writeCRef ref a = toConc (\c -> AWriteCRef ref a (c ()))
casCRef ref tick a = toConc (ACasCRef ref tick a)
atomicModifyCRef ref f = toConc (AModCRef ref f)
modifyCRefCAS ref f = toConc (AModCRefCas ref f)
newEmptyMVarN n = toConc (ANewMVar n)
putMVar var a = toConc (\c -> APutMVar var a (c ()))
readMVar var = toConc (AReadMVar var)
takeMVar var = toConc (ATakeMVar var)
tryPutMVar var a = toConc (ATryPutMVar var a)
tryReadMVar var = toConc (ATryReadMVar var)
tryTakeMVar var = toConc (ATryTakeMVar var)
throwTo tid e = toConc (\c -> AThrowTo tid e (c ()))
atomically = toConc . AAtom
runConcurrent :: MonadRef r n
=> Scheduler s
-> MemType
-> s
-> ConcT r n a
-> n (Either Failure a, s, Trace)
runConcurrent sched memtype s ma = do
(res, ctx, trace, _) <- runConcurrency sched memtype s initialIdSource 2 (unC ma)
pure (res, cSchedState ctx, F.toList trace)
subconcurrency :: ConcT r n a -> ConcT r n (Either Failure a)
subconcurrency ma = toConc (ASub (unC ma))