module Test.DejaFu.Deterministic
(
Conc
, ConcST
, ConcIO
, Failure(..)
, MemType(..)
, runConcST
, runConcIO
, Trace
, Decision(..)
, ThreadId(..)
, ThreadAction(..)
, Lookahead(..)
, MVarId
, CRefId
, MaskingState(..)
, showTrace
, showFail
, module Test.DPOR.Schedule
) where
import Control.Exception (MaskingState(..))
import Control.Monad.ST (ST, runST)
import Data.Dynamic (toDyn)
import Data.IORef (IORef)
import Data.STRef (STRef)
import Test.DejaFu.Deterministic.Internal
import Test.DejaFu.Internal (refST, refIO)
import Test.DejaFu.STM (STMLike, STMIO, STMST, runTransactionIO, runTransactionST)
import Test.DejaFu.STM.Internal (TVar(..))
import Test.DPOR.Schedule
import qualified Control.Monad.Base as Ba
import qualified Control.Monad.Catch as Ca
import qualified Control.Monad.Conc.Class as C
import qualified Control.Monad.IO.Class as IO
newtype Conc n r s a = C { unC :: M n r s a } deriving (Functor, Applicative, Monad)
type ConcST t = Conc (ST t) (STRef t) (STMST t)
type ConcIO = Conc IO IORef STMIO
toConc :: ((a -> Action n r s) -> Action n r s) -> Conc n r s a
toConc = C . cont
wrap :: (M n r s a -> M n r s a) -> Conc n r s a -> Conc n r s 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 s) where
catch ma h = toConc (ACatching (unC . h) (unC ma))
instance Ca.MonadThrow (Conc n r s) where
throwM e = toConc (\_ -> AThrow e)
instance Ca.MonadMask (Conc n r s) 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 (STMLike n r)) where
type MVar (Conc n r (STMLike n r)) = MVar r
type CRef (Conc n r (STMLike n r)) = CRef r
type Ticket (Conc n r (STMLike n r)) = Ticket
type STM (Conc n r (STMLike n r)) = STMLike n r
type ThreadId (Conc n r (STMLike n r)) = ThreadId
forkWithUnmaskN n ma = toConc (AFork n (\umask -> runCont (unC $ ma $ wrap umask) (\_ -> AStop)))
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 -> ANewRef n a c)
readCRef ref = toConc (AReadRef ref)
readForCAS ref = toConc (AReadRefCas ref)
peekTicket tick = toConc (APeekTicket tick)
writeCRef ref a = toConc (\c -> AWriteRef ref a (c ()))
casCRef ref tick a = toConc (ACasRef ref tick a)
atomicModifyCRef ref f = toConc (AModRef ref f)
modifyCRefCAS ref f = toConc (AModRefCas ref f)
newEmptyMVarN n = toConc (\c -> ANewVar n c)
putMVar var a = toConc (\c -> APutVar var a (c ()))
readMVar var = toConc (AReadVar var)
takeMVar var = toConc (ATakeVar var)
tryPutMVar var a = toConc (ATryPutVar var a)
tryTakeMVar var = toConc (ATryTakeVar var)
throwTo tid e = toConc (\c -> AThrowTo tid e (c ()))
atomically = toConc . AAtom
_concKnowsAbout (Left (MVar cvarid _)) = toConc (\c -> AKnowsAbout (Left cvarid) (c ()))
_concKnowsAbout (Right (TVar (ctvarid, _))) = toConc (\c -> AKnowsAbout (Right ctvarid) (c ()))
_concForgets (Left (MVar cvarid _)) = toConc (\c -> AForgets (Left cvarid) (c ()))
_concForgets (Right (TVar (ctvarid, _))) = toConc (\c -> AForgets (Right ctvarid) (c ()))
_concAllKnown = toConc (\c -> AAllKnown (c ()))
_concMessage msg = toConc (\c -> AMessage (toDyn msg) (c ()))
runConcST :: Scheduler ThreadId ThreadAction Lookahead s -> MemType -> s -> (forall t. ConcST t a) -> (Either Failure a, s, Trace ThreadId ThreadAction Lookahead)
runConcST sched memtype s ma = runST $ runFixed fixed runTransactionST sched memtype s $ unC ma where
fixed = refST $ \mb -> cont (\c -> ALift $ c <$> mb)
runConcIO :: Scheduler ThreadId ThreadAction Lookahead s -> MemType -> s -> ConcIO a -> IO (Either Failure a, s, Trace ThreadId ThreadAction Lookahead)
runConcIO sched memtype s ma = runFixed fixed runTransactionIO sched memtype s $ unC ma where
fixed = refIO $ \mb -> cont (\c -> ALift $ c <$> mb)