module Test.DejaFu.Deterministic.IO
(
ConcIO
, Failure(..)
, runConcIO
, runConcIO'
, liftIO
, fork
, forkFinally
, forkWithUnmask
, forkOn
, getNumCapabilities
, myThreadId
, spawn
, atomically
, throw
, throwTo
, killThread
, Test.DejaFu.Deterministic.IO.catch
, mask
, uninterruptibleMask
, CVar
, newEmptyCVar
, putCVar
, tryPutCVar
, readCVar
, takeCVar
, tryTakeCVar
, CRef
, newCRef
, readCRef
, writeCRef
, modifyCRef
, _concNoTest
, _concKnowsAbout
, _concForgets
, _concAllKnown
, Trace
, Trace'
, Decision(..)
, ThreadAction(..)
, Lookahead(..)
, CVarId
, MaskingState(..)
, showTrace
, toTrace
, module Test.DejaFu.Deterministic.Schedule
) where
import Control.Exception (Exception, MaskingState(..), SomeException(..))
import Control.Monad.Cont (cont, runCont)
import Data.IORef (IORef, newIORef)
import Test.DejaFu.Deterministic.Internal
import Test.DejaFu.Deterministic.Schedule
import Test.DejaFu.Internal (refIO)
import Test.DejaFu.STM (STMLike, runTransactionIO)
import Test.DejaFu.STM.Internal (CTVar(..))
import qualified Control.Monad.Catch as Ca
import qualified Control.Monad.Conc.Class as C
import qualified Control.Monad.IO.Class as IO
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..), (<$>))
#endif
newtype ConcIO t a = C { unC :: M IO IORef (STMLike t) a } deriving (Functor, Applicative, Monad)
wrap :: (M IO IORef (STMLike t) a -> M IO IORef (STMLike t) a) -> ConcIO t a -> ConcIO t a
wrap f = C . f . unC
instance Ca.MonadCatch (ConcIO t) where
catch = Test.DejaFu.Deterministic.IO.catch
instance Ca.MonadThrow (ConcIO t) where
throwM = throw
instance Ca.MonadMask (ConcIO t) where
mask = mask
uninterruptibleMask = uninterruptibleMask
instance IO.MonadIO (ConcIO t) where
liftIO = liftIO
instance C.MonadConc (ConcIO t) where
type CVar (ConcIO t) = CVar t
type CRef (ConcIO t) = CRef t
type STMLike (ConcIO t) = STMLike t IO IORef
type ThreadId (ConcIO t) = Int
fork = fork
forkWithUnmask = forkWithUnmask
forkOn = forkOn
getNumCapabilities = getNumCapabilities
myThreadId = myThreadId
throwTo = throwTo
newEmptyCVar = newEmptyCVar
putCVar = putCVar
tryPutCVar = tryPutCVar
readCVar = readCVar
takeCVar = takeCVar
tryTakeCVar = tryTakeCVar
newCRef = newCRef
readCRef = readCRef
writeCRef = writeCRef
modifyCRef = modifyCRef
atomically = atomically
_concNoTest = _concNoTest
_concKnowsAbout = _concKnowsAbout
_concForgets = _concForgets
_concAllKnown = _concAllKnown
fixed :: Fixed IO IORef (STMLike t)
fixed = refIO $ unC . liftIO
newtype CVar t a = Var { unV :: V IORef a } deriving Eq
newtype CRef t a = Ref { unR :: R IORef a } deriving Eq
liftIO :: IO a -> ConcIO t a
liftIO ma = C $ cont lifted where
lifted c = ALift $ c <$> ma
spawn :: ConcIO t a -> ConcIO t (CVar t a)
spawn = C.spawn
readCVar :: CVar t a -> ConcIO t a
readCVar cvar = C $ cont $ AGet $ unV cvar
fork :: ConcIO t () -> ConcIO t ThreadId
fork (C ma) = C $ cont $ AFork (const' $ runCont ma $ const AStop)
myThreadId :: ConcIO t ThreadId
myThreadId = C $ cont AMyTId
atomically :: STMLike t IO IORef a -> ConcIO t a
atomically stm = C $ cont $ AAtom stm
newEmptyCVar :: ConcIO t (CVar t a)
newEmptyCVar = C $ cont lifted where
lifted c = ANew $ \cvid -> c <$> newEmptyCVar' cvid
newEmptyCVar' cvid = (\ref -> Var (cvid, ref)) <$> newIORef Nothing
putCVar :: CVar t a -> a -> ConcIO t ()
putCVar cvar a = C $ cont $ \c -> APut (unV cvar) a $ c ()
tryPutCVar :: CVar t a -> a -> ConcIO t Bool
tryPutCVar cvar a = C $ cont $ ATryPut (unV cvar) a
takeCVar :: CVar t a -> ConcIO t a
takeCVar cvar = C $ cont $ ATake $ unV cvar
tryTakeCVar :: CVar t a -> ConcIO t (Maybe a)
tryTakeCVar cvar = C $ cont $ ATryTake $ unV cvar
newCRef :: a -> ConcIO t (CRef t a)
newCRef a = C $ cont lifted where
lifted c = ANewRef $ \crid -> c <$> newCRef' crid
newCRef' crid = (\ref -> Ref (crid, ref)) <$> newIORef a
readCRef :: CRef t a -> ConcIO t a
readCRef ref = C $ cont $ AReadRef $ unR ref
modifyCRef :: CRef t a -> (a -> (a, b)) -> ConcIO t b
modifyCRef ref f = C $ cont $ AModRef (unR ref) f
writeCRef :: CRef t a -> a -> ConcIO t ()
writeCRef ref a = modifyCRef ref $ const (a, ())
throw :: Exception e => e -> ConcIO t a
throw e = C $ cont $ \_ -> AThrow (SomeException e)
throwTo :: Exception e => ThreadId -> e -> ConcIO t ()
throwTo tid e = C $ cont $ \c -> AThrowTo tid (SomeException e) $ c ()
killThread :: ThreadId -> ConcIO t ()
killThread = C.killThread
catch :: Exception e => ConcIO t a -> (e -> ConcIO t a) -> ConcIO t a
catch ma h = C $ cont $ ACatching (unC . h) (unC ma)
forkFinally :: ConcIO t a -> (Either SomeException a -> ConcIO t ()) -> ConcIO t ThreadId
forkFinally action and_then = mask $ \restore ->
fork $ Ca.try (restore action) >>= and_then
forkWithUnmask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t ()) -> ConcIO t ThreadId
forkWithUnmask ma = C $ cont $
AFork (\umask -> runCont (unC $ ma $ wrap umask) $ const AStop)
mask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t b) -> ConcIO t b
mask mb = C $ cont $ AMasking MaskedInterruptible (\f -> unC $ mb $ wrap f)
uninterruptibleMask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t b) -> ConcIO t b
uninterruptibleMask mb = C $ cont $
AMasking MaskedUninterruptible (\f -> unC $ mb $ wrap f)
forkOn :: Int -> ConcIO t () -> ConcIO t ThreadId
forkOn _ = fork
getNumCapabilities :: ConcIO t Int
getNumCapabilities = return 2
_concNoTest :: ConcIO t a -> ConcIO t a
_concNoTest ma = C $ cont $ \c -> ANoTest (unC ma) c
_concKnowsAbout :: Either (CVar t a) (CTVar t IORef a) -> ConcIO t ()
_concKnowsAbout (Left (Var (cvarid, _))) = C $ cont $ \c -> AKnowsAbout (Left cvarid) (c ())
_concKnowsAbout (Right (V (ctvarid, _))) = C $ cont $ \c -> AKnowsAbout (Right ctvarid) (c ())
_concForgets :: Either (CVar t a) (CTVar t IORef a) -> ConcIO t ()
_concForgets (Left (Var (cvarid, _))) = C $ cont $ \c -> AForgets (Left cvarid) (c ())
_concForgets (Right (V (ctvarid, _))) = C $ cont $ \c -> AForgets (Right ctvarid) (c ())
_concAllKnown :: ConcIO t ()
_concAllKnown = C $ cont $ \c -> AAllKnown (c ())
runConcIO :: Scheduler s -> s -> (forall t. ConcIO t a) -> IO (Either Failure a, s, Trace)
runConcIO sched s ma = do
(r, s', t') <- runConcIO' sched s ma
return (r, s', toTrace t')
runConcIO' :: Scheduler s -> s -> (forall t. ConcIO t a) -> IO (Either Failure a, s, Trace')
runConcIO' sched s ma = runFixed fixed runTransactionIO sched s $ unC ma