module Test.DejaFu.Conc
(
Conc
, 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 Control.Monad.ST (ST)
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 Conc n r a = C { unC :: M n r a } deriving (Functor, Applicative, Monad)
type ConcST t = Conc (ST t) (STRef t)
type ConcIO = Conc IO IORef
toConc :: ((a -> Action n r) -> Action n r) -> Conc n r a
toConc = C . cont
wrap :: (M n r a -> M n r a) -> Conc n r a -> Conc n r 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 Ca.MonadCatch (Conc n r) where
catch ma h = toConc (ACatching (unC . h) (unC ma))
instance Ca.MonadThrow (Conc n r) where
throwM e = toConc (\_ -> AThrow e)
instance Ca.MonadMask (Conc n r) 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
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 (\c -> ANewCRef n a c)
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 (\c -> ANewMVar n c)
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
-> Conc n r a
-> n (Either Failure a, s, Trace)
runConcurrent sched memtype s ma = do
(res, s', trace) <- runConcurrency sched memtype s 2 (unC ma)
pure (res, s', F.toList trace)
subconcurrency :: Conc n r a -> Conc n r (Either Failure a)
subconcurrency ma = toConc (ASub (unC ma))