{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Control.Monad.IOSim (
  -- * Simulation monad
  IOSim,
  STMSim,
  -- ** Run simulation
  runSim,
  runSimOrThrow,
  runSimStrictShutdown,
  Failure(..),
  runSimTrace,
  runSimTraceST,
  liftST,
  traceM,
  -- * Simulation time
  setCurrentTime,
  unshareClock,
  -- * Simulation trace
  Trace(..),
  TraceEvent(..),
  ThreadLabel,
  LabeledThread (..),
  traceEvents,
  traceResult,
  selectTraceEvents,
  selectTraceEventsDynamic,
  selectTraceEventsSay,
  printTraceEventsSay,
  -- * Eventlog
  EventlogEvent(..),
  EventlogMarker(..),
  -- * Low-level API
  execReadTVar,
  -- * Deprecated interfaces
  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 :: (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]
_) = []

-- | Select all the traced values matching the expected type. This relies on
-- the sim's dynamic trace facility.
--
-- For convenience, this throws exceptions for abnormal sim termination.
--
selectTraceEventsDynamic :: forall a b. Typeable b => Trace a -> [b]
selectTraceEventsDynamic :: 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

-- | Get a trace of 'EventSay'.
--
-- For convenience, this throws exceptions for abnormal sim termination.
--
selectTraceEventsSay :: Trace a -> [String]
selectTraceEventsSay :: 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

-- | Print all 'EventSay' to the console.
--
-- For convenience, this throws exceptions for abnormal sim termination.
--
printTraceEventsSay :: Trace a -> IO ()
printTraceEventsSay :: 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

-- | Simulation termination with failure
--
data Failure =
       -- | The main thread terminated with an exception
       FailureException SomeException

       -- | The threads all deadlocked
     | FailureDeadlock

       -- | The main thread terminated normally but other threads were still
       -- alive, and strict shutdown checking was requested.
       -- See 'runSimStrictShutdown'
     | 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
">>"
             ]

-- | 'IOSim' is a pure monad.
--
runSim :: forall a. (forall s. IOSim s a) -> Either Failure a
runSim :: (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)

-- | For quick experiments and tests it is often appropriate and convenient to
-- simply throw failures as exceptions.
--
runSimOrThrow :: forall a. (forall s. IOSim s a) -> a
runSimOrThrow :: (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

-- | Like 'runSim' but also fail if when the main thread terminates, there
-- are other threads still running or blocked. If one is trying to follow
-- a strict thread cleanup policy then this helps testing for that.
--
runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a
runSimStrictShutdown :: (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 :: 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 :: 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
_                             = []



-- | See 'runSimTraceST' below.
--
runSimTrace :: forall a. (forall s. IOSim s a) -> Trace a
runSimTrace :: (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)