{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Monad.IOSim (
IOSim,
STMSim,
runSim,
runSimOrThrow,
runSimStrictShutdown,
Failure(..),
runSimTrace,
runSimTraceST,
liftST,
traceM,
setCurrentTime,
unshareClock,
Trace(..),
TraceEvent(..),
ThreadLabel,
LabeledThread (..),
traceEvents,
traceResult,
selectTraceEvents,
selectTraceEventsDynamic,
selectTraceEventsSay,
printTraceEventsSay,
EventlogEvent(..),
EventlogMarker(..),
execReadTVar,
SimM,
SimSTM
) where
import Prelude
import Data.Dynamic (fromDynamic)
import Data.List (intercalate)
import Data.Typeable (Typeable)
import Control.Exception (throw)
import Control.Monad.ST.Lazy
import Control.Monad.Class.MonadThrow as MonadThrow
import Control.Monad.Class.MonadTime
import Control.Monad.IOSim.Internal
selectTraceEvents
:: (TraceEvent -> Maybe b)
-> Trace a
-> [b]
selectTraceEvents :: forall b a. (TraceEvent -> Maybe b) -> Trace a -> [b]
selectTraceEvents TraceEvent -> Maybe b
fn = Trace a -> [b]
forall {a}. Trace a -> [b]
go
where
go :: Trace a -> [b]
go (Trace Time
_ ThreadId
_ Maybe ThreadLabel
_ TraceEvent
ev Trace a
trace) = case TraceEvent -> Maybe b
fn TraceEvent
ev of
Just b
x -> b
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Trace a -> [b]
go Trace a
trace
Maybe b
Nothing -> Trace a -> [b]
go Trace a
trace
go (TraceMainException Time
_ SomeException
e [LabeledThread]
_) = Failure -> [b]
forall a e. Exception e => e -> a
throw (SomeException -> Failure
FailureException SomeException
e)
go (TraceDeadlock Time
_ [LabeledThread]
_) = Failure -> [b]
forall a e. Exception e => e -> a
throw Failure
FailureDeadlock
go (TraceMainReturn Time
_ a
_ [LabeledThread]
_) = []
selectTraceEventsDynamic :: forall a b. Typeable b => Trace a -> [b]
selectTraceEventsDynamic :: forall a b. Typeable b => Trace a -> [b]
selectTraceEventsDynamic = (TraceEvent -> Maybe b) -> Trace a -> [b]
forall b a. (TraceEvent -> Maybe b) -> Trace a -> [b]
selectTraceEvents TraceEvent -> Maybe b
fn
where
fn :: TraceEvent -> Maybe b
fn :: TraceEvent -> Maybe b
fn (EventLog Dynamic
dyn) = Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn
fn TraceEvent
_ = Maybe b
forall a. Maybe a
Nothing
selectTraceEventsSay :: Trace a -> [String]
selectTraceEventsSay :: forall a. Trace a -> [ThreadLabel]
selectTraceEventsSay = (TraceEvent -> Maybe ThreadLabel) -> Trace a -> [ThreadLabel]
forall b a. (TraceEvent -> Maybe b) -> Trace a -> [b]
selectTraceEvents TraceEvent -> Maybe ThreadLabel
fn
where
fn :: TraceEvent -> Maybe String
fn :: TraceEvent -> Maybe ThreadLabel
fn (EventSay ThreadLabel
s) = ThreadLabel -> Maybe ThreadLabel
forall a. a -> Maybe a
Just ThreadLabel
s
fn TraceEvent
_ = Maybe ThreadLabel
forall a. Maybe a
Nothing
printTraceEventsSay :: Trace a -> IO ()
printTraceEventsSay :: forall a. Trace a -> IO ()
printTraceEventsSay = (ThreadLabel -> IO ()) -> [ThreadLabel] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadLabel -> IO ()
forall a. Show a => a -> IO ()
print ([ThreadLabel] -> IO ())
-> (Trace a -> [ThreadLabel]) -> Trace a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace a -> [ThreadLabel]
forall a. Trace a -> [ThreadLabel]
selectTraceEventsSay
data Failure =
FailureException SomeException
| FailureDeadlock
| FailureSloppyShutdown [LabeledThread]
deriving Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> ThreadLabel
(Int -> Failure -> ShowS)
-> (Failure -> ThreadLabel) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS)
-> (a -> ThreadLabel) -> ([a] -> ShowS) -> Show a
showList :: [Failure] -> ShowS
$cshowList :: [Failure] -> ShowS
show :: Failure -> ThreadLabel
$cshow :: Failure -> ThreadLabel
showsPrec :: Int -> Failure -> ShowS
$cshowsPrec :: Int -> Failure -> ShowS
Show
instance Exception Failure where
displayException :: Failure -> ThreadLabel
displayException (FailureException SomeException
err) = SomeException -> ThreadLabel
forall e. Exception e => e -> ThreadLabel
displayException SomeException
err
displayException Failure
FailureDeadlock = ThreadLabel
"<<io-sim deadlock>>"
displayException (FailureSloppyShutdown [LabeledThread]
threads) =
[ThreadLabel] -> ThreadLabel
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ThreadLabel
"<<io-sim sloppy shutdown: "
, ThreadLabel -> [ThreadLabel] -> ThreadLabel
forall a. [a] -> [[a]] -> [a]
intercalate ThreadLabel
"," (LabeledThread -> ThreadLabel
forall a. Show a => a -> ThreadLabel
show (LabeledThread -> ThreadLabel) -> [LabeledThread] -> [ThreadLabel]
forall a b. (a -> b) -> [a] -> [b]
`map` [LabeledThread]
threads)
, ThreadLabel
">>"
]
runSim :: forall a. (forall s. IOSim s a) -> Either Failure a
runSim :: forall a. (forall s. IOSim s a) -> Either Failure a
runSim forall s. IOSim s a
mainAction = Bool -> Trace a -> Either Failure a
forall a. Bool -> Trace a -> Either Failure a
traceResult Bool
False ((forall s. IOSim s a) -> Trace a
forall a. (forall s. IOSim s a) -> Trace a
runSimTrace forall s. IOSim s a
mainAction)
runSimOrThrow :: forall a. (forall s. IOSim s a) -> a
runSimOrThrow :: forall a. (forall s. IOSim s a) -> a
runSimOrThrow forall s. IOSim s a
mainAction =
case (forall s. IOSim s a) -> Either Failure a
forall a. (forall s. IOSim s a) -> Either Failure a
runSim forall s. IOSim s a
mainAction of
Left Failure
e -> Failure -> a
forall a e. Exception e => e -> a
throw Failure
e
Right a
x -> a
x
runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a
runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a
runSimStrictShutdown forall s. IOSim s a
mainAction = Bool -> Trace a -> Either Failure a
forall a. Bool -> Trace a -> Either Failure a
traceResult Bool
True ((forall s. IOSim s a) -> Trace a
forall a. (forall s. IOSim s a) -> Trace a
runSimTrace forall s. IOSim s a
mainAction)
traceResult :: Bool -> Trace a -> Either Failure a
traceResult :: forall a. Bool -> Trace a -> Either Failure a
traceResult Bool
strict = Trace a -> Either Failure a
forall {b}. Trace b -> Either Failure b
go
where
go :: Trace b -> Either Failure b
go (Trace Time
_ ThreadId
_ Maybe ThreadLabel
_ TraceEvent
_ Trace b
t) = Trace b -> Either Failure b
go Trace b
t
go (TraceMainReturn Time
_ b
_ tids :: [LabeledThread]
tids@(LabeledThread
_:[LabeledThread]
_))
| Bool
strict = Failure -> Either Failure b
forall a b. a -> Either a b
Left ([LabeledThread] -> Failure
FailureSloppyShutdown [LabeledThread]
tids)
go (TraceMainReturn Time
_ b
x [LabeledThread]
_) = b -> Either Failure b
forall a b. b -> Either a b
Right b
x
go (TraceMainException Time
_ SomeException
e [LabeledThread]
_) = Failure -> Either Failure b
forall a b. a -> Either a b
Left (SomeException -> Failure
FailureException SomeException
e)
go (TraceDeadlock Time
_ [LabeledThread]
_) = Failure -> Either Failure b
forall a b. a -> Either a b
Left Failure
FailureDeadlock
traceEvents :: Trace a -> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
traceEvents :: forall a.
Trace a -> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
traceEvents (Trace Time
time ThreadId
tid Maybe ThreadLabel
tlbl TraceEvent
event Trace a
t) = (Time
time, ThreadId
tid, Maybe ThreadLabel
tlbl, TraceEvent
event)
(Time, ThreadId, Maybe ThreadLabel, TraceEvent)
-> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
-> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
forall a. a -> [a] -> [a]
: Trace a -> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
forall a.
Trace a -> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
traceEvents Trace a
t
traceEvents Trace a
_ = []
runSimTrace :: forall a. (forall s. IOSim s a) -> Trace a
runSimTrace :: forall a. (forall s. IOSim s a) -> Trace a
runSimTrace forall s. IOSim s a
mainAction = (forall s. ST s (Trace a)) -> Trace a
forall a. (forall s. ST s a) -> a
runST (IOSim s a -> ST s (Trace a)
forall s a. IOSim s a -> ST s (Trace a)
runSimTraceST IOSim s a
forall s. IOSim s a
mainAction)