{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTSyntax                 #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE NumericUnderscores         #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeFamilies               #-}

-- Needed for `SimEvent` type.
{-# OPTIONS_GHC -Wno-partial-fields     #-}

module Control.Monad.IOSim.Types
  ( IOSim (..)
  , runIOSim
  , traceM
  , traceSTM
  , liftST
  , SimA (..)
  , STMSim
  , STM (..)
  , runSTM
  , StmA (..)
  , StmTxResult (..)
  , BranchStmA (..)
  , StmStack (..)
  , TimeoutException (..)
  , setCurrentTime
  , unshareClock
  , ScheduleControl (..)
  , isDefaultSchedule
  , ScheduleMod (..)
  , ExplorationOptions (..)
  , ExplorationSpec
  , withScheduleBound
  , withBranching
  , withStepTimelimit
  , withReplay
  , stdExplorationOptions
  , EventlogEvent (..)
  , EventlogMarker (..)
  , SimEventType (..)
  , ppSimEventType
  , SimEvent (..)
  , SimResult (..)
  , ppSimResult
  , SimTrace
  , Trace.Trace (SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceRacesFound, TraceLoop, TraceInternalError)
  , ppTrace
  , ppTrace_
  , ppSimEvent
  , ppDebug
  , Labelled (..)
  , module Control.Monad.IOSim.CommonTypes
  , Thrower (..)
  , Time (..)
  , addTime
  , diffTime
    -- * Internal API
  , Timeout (..)
  , newTimeout
  , readTimeout
  , cancelTimeout
  , awaitTimeout
    -- * Low-level API
  , execReadTVar
  ) where

import           Control.Applicative
import           Control.Exception (ErrorCall (..), asyncExceptionFromException,
                     asyncExceptionToException)
import           Control.Monad
import           Control.Monad.Fix (MonadFix (..))

import           Control.Concurrent.Class.MonadMVar
import           Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)
import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar
import           Control.Monad.Class.MonadAsync hiding (Async)
import qualified Control.Monad.Class.MonadAsync as MonadAsync
import           Control.Monad.Class.MonadEventlog
import           Control.Monad.Class.MonadFork
import           Control.Monad.Class.MonadST
import           Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..),
                     MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..),
                     TArrayDefault, TChanDefault, TMVarDefault, TSemDefault,
                     TraceValue, atomically, retry)
import qualified Control.Monad.Class.MonadSTM.Internal as MonadSTM
import           Control.Monad.Class.MonadSay
import           Control.Monad.Class.MonadTest
import           Control.Monad.Class.MonadThrow as MonadThrow hiding
                     (getMaskingState)
import qualified Control.Monad.Class.MonadThrow as MonadThrow
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTime.SI
import           Control.Monad.Class.MonadTimer
import           Control.Monad.Class.MonadTimer.SI (TimeoutState (..))
import qualified Control.Monad.Class.MonadTimer.SI as SI
import           Control.Monad.ST.Lazy
import qualified Control.Monad.ST.Strict as StrictST
import           Control.Monad.ST.Unsafe (unsafeSTToIO)

import qualified Control.Monad.Catch as Exceptions
import qualified Control.Monad.Fail as Fail

import           Data.Bifoldable
import           Data.Bifunctor (bimap)
import           Data.Dynamic (Dynamic, toDyn)
import qualified Data.List.Trace as Trace
import           Data.Map.Strict (Map)
import           Data.Maybe (fromMaybe)
import           Data.Monoid (Endo (..))
import           Data.STRef.Lazy
import           Data.Semigroup (Max (..))
import           Data.Time.Clock (diffTimeToPicoseconds)
import           Data.Typeable
import           Data.Word (Word64)
import qualified Debug.Trace as Debug
import           NoThunks.Class (NoThunks (..))
import           Text.Printf

import           GHC.Exts (oneShot)
import           GHC.Generics (Generic)
import           Quiet (Quiet (..))

import           Control.Monad.IOSim.CommonTypes
import           Control.Monad.IOSim.STM
import           Control.Monad.IOSimPOR.Types


import qualified System.IO.Error as IO.Error (userError)
import Data.List (intercalate)

{-# ANN module "HLint: ignore Use readTVarIO" #-}
newtype IOSim s a = IOSim { forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim :: forall r. (a -> SimA s r) -> SimA s r }

runIOSim :: IOSim s a -> SimA s a
runIOSim :: forall s a. IOSim s a -> SimA s a
runIOSim (IOSim forall r. (a -> SimA s r) -> SimA s r
k) = forall r. (a -> SimA s r) -> SimA s r
k forall a s. a -> SimA s a
Return

-- | 'IOSim' has the ability to story any 'Typeable' value in its trace which
-- can then be recovered with `selectTraceEventsDynamic` or
-- `selectTraceEventsDynamic'`.
--
traceM :: Typeable a => a -> IOSim s ()
traceM :: forall a s. Typeable a => a -> IOSim s ()
traceM a
x = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s b. Dynamic -> SimA s b -> SimA s b
Output (forall a. Typeable a => a -> Dynamic
toDyn a
x) (() -> SimA s r
k ())

-- | Trace a value, in the same was as `traceM` does, but from the `STM` monad.
-- This is primarily useful for debugging.
--
traceSTM :: Typeable a => a -> STMSim s ()
traceSTM :: forall a s. Typeable a => a -> STMSim s ()
traceSTM a
x = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> forall s b. Dynamic -> StmA s b -> StmA s b
OutputStm (forall a. Typeable a => a -> Dynamic
toDyn a
x) (() -> StmA s r
k ())

data Thrower = ThrowSelf | ThrowOther deriving (Eq Thrower
Thrower -> Thrower -> Bool
Thrower -> Thrower -> Ordering
Thrower -> Thrower -> Thrower
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Thrower -> Thrower -> Thrower
$cmin :: Thrower -> Thrower -> Thrower
max :: Thrower -> Thrower -> Thrower
$cmax :: Thrower -> Thrower -> Thrower
>= :: Thrower -> Thrower -> Bool
$c>= :: Thrower -> Thrower -> Bool
> :: Thrower -> Thrower -> Bool
$c> :: Thrower -> Thrower -> Bool
<= :: Thrower -> Thrower -> Bool
$c<= :: Thrower -> Thrower -> Bool
< :: Thrower -> Thrower -> Bool
$c< :: Thrower -> Thrower -> Bool
compare :: Thrower -> Thrower -> Ordering
$ccompare :: Thrower -> Thrower -> Ordering
Ord, Thrower -> Thrower -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Thrower -> Thrower -> Bool
$c/= :: Thrower -> Thrower -> Bool
== :: Thrower -> Thrower -> Bool
$c== :: Thrower -> Thrower -> Bool
Eq, Int -> Thrower -> String -> String
[Thrower] -> String -> String
Thrower -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Thrower] -> String -> String
$cshowList :: [Thrower] -> String -> String
show :: Thrower -> String
$cshow :: Thrower -> String
showsPrec :: Int -> Thrower -> String -> String
$cshowsPrec :: Int -> Thrower -> String -> String
Show)

data SimA s a where
  Return       :: a -> SimA s a

  Say          :: String -> SimA s b -> SimA s b
  Output       :: Dynamic -> SimA s b -> SimA s b

  LiftST       :: StrictST.ST s a -> (a -> SimA s b) -> SimA s b

  GetMonoTime  :: (Time    -> SimA s b) -> SimA s b
  GetWallTime  :: (UTCTime -> SimA s b) -> SimA s b
  SetWallTime  ::  UTCTime -> SimA s b  -> SimA s b
  UnshareClock :: SimA s b -> SimA s b

  StartTimeout      :: DiffTime -> SimA s a -> (Maybe a -> SimA s b) -> SimA s b
  UnregisterTimeout :: TimeoutId -> SimA s a -> SimA s a
  RegisterDelay     :: DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b
  ThreadDelay       :: DiffTime -> SimA s b -> SimA s b

  NewTimeout    :: DiffTime -> (Timeout s -> SimA s b) -> SimA s b
  CancelTimeout :: Timeout s -> SimA s b -> SimA s b

  Throw        :: SomeException -> SimA s a
  Catch        :: Exception e =>
                  SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b
  Evaluate     :: a -> (a -> SimA s b) -> SimA s b

  Fork         :: IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
  GetThreadId  :: (IOSimThreadId -> SimA s b) -> SimA s b
  LabelThread  :: IOSimThreadId -> String -> SimA s b -> SimA s b

  Atomically   :: STM  s a -> (a -> SimA s b) -> SimA s b

  ThrowTo      :: SomeException -> IOSimThreadId -> SimA s a -> SimA s a
  SetMaskState :: MaskingState  -> IOSim s a -> (a -> SimA s b) -> SimA s b
  GetMaskState :: (MaskingState -> SimA s b) -> SimA s b

  YieldSim     :: SimA s a -> SimA s a

  ExploreRaces :: SimA s b -> SimA s b

  Fix          :: (x -> IOSim s x) -> (x -> SimA s r) -> SimA s r


newtype STM s a = STM { forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM :: forall r. (a -> StmA s r) -> StmA s r }

instance Semigroup a => Semigroup (STM s a) where
    STM s a
a <> :: STM s a -> STM s a -> STM s a
<> STM s a
b = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM s a
b

instance Monoid a => Monoid (STM s a) where
    mempty :: STM s a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

runSTM :: STM s a -> StmA s a
runSTM :: forall s a. STM s a -> StmA s a
runSTM (STM forall r. (a -> StmA s r) -> StmA s r
k) = forall r. (a -> StmA s r) -> StmA s r
k forall a s. a -> StmA s a
ReturnStm

data StmA s a where
  ReturnStm    :: a -> StmA s a
  ThrowStm     :: SomeException -> StmA s a
  CatchStm     :: StmA s a -> (SomeException -> StmA s a) -> (a -> StmA s b) -> StmA s b

  NewTVar      :: Maybe String -> x -> (TVar s x -> StmA s b) -> StmA s b
  LabelTVar    :: String -> TVar s a -> StmA s b -> StmA s b
  ReadTVar     :: TVar s a -> (a -> StmA s b) -> StmA s b
  WriteTVar    :: TVar s a ->  a -> StmA s b  -> StmA s b
  Retry        :: StmA s b
  OrElse       :: StmA s a -> StmA s a -> (a -> StmA s b) -> StmA s b

  SayStm       :: String -> StmA s b -> StmA s b
  OutputStm    :: Dynamic -> StmA s b -> StmA s b
  TraceTVar    :: forall s a b.
                  TVar s a
               -> (Maybe a -> a -> ST s TraceValue)
               -> StmA s b -> StmA s b

  LiftSTStm    :: StrictST.ST s a -> (a -> StmA s b) -> StmA s b
  FixStm       :: (x -> STM s x) -> (x -> StmA s r) -> StmA s r

-- Exported type
type STMSim = STM

--
-- Monad class instances
--

instance Functor (IOSim s) where
    {-# INLINE fmap #-}
    fmap :: forall a b. (a -> b) -> IOSim s a -> IOSim s b
fmap a -> b
f = \IOSim s a
d -> forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
d (b -> SimA s r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative (IOSim s) where
    {-# INLINE pure #-}
    pure :: forall a. a -> IOSim s a
pure = \a
x -> forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> a -> SimA s r
k a
x

    {-# INLINE (<*>) #-}
    <*> :: forall a b. IOSim s (a -> b) -> IOSim s a -> IOSim s b
(<*>) = \IOSim s (a -> b)
df IOSim s a
dx -> forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k ->
                        forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s (a -> b)
df (\a -> b
f -> forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dx (\a
x -> b -> SimA s r
k (a -> b
f a
x)))

    {-# INLINE (*>) #-}
    *> :: forall a b. IOSim s a -> IOSim s b -> IOSim s b
(*>) = \IOSim s a
dm IOSim s b
dn -> forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dm (\a
_ -> forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s b
dn b -> SimA s r
k)

instance Monad (IOSim s) where
    return :: forall a. a -> IOSim s a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>=) #-}
    >>= :: forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
(>>=) = \IOSim s a
dm a -> IOSim s b
f -> forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dm (\a
m -> forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim (a -> IOSim s b
f a
m) b -> SimA s r
k)

    {-# INLINE (>>) #-}
    >> :: forall a b. IOSim s a -> IOSim s b -> IOSim s b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

#if !(MIN_VERSION_base(4,13,0))
    fail = Fail.fail
#endif

instance Semigroup a => Semigroup (IOSim s a) where
    <> :: IOSim s a -> IOSim s a -> IOSim s a
(<>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (IOSim s a) where
    mempty :: IOSim s a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

#if !(MIN_VERSION_base(4,11,0))
    mappend = liftA2 mappend
#endif

instance Fail.MonadFail (IOSim s) where
  fail :: forall a. String -> IOSim s a
fail String
msg = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
_ -> forall s a. SomeException -> SimA s a
Throw (forall e. Exception e => e -> SomeException
toException (String -> IOError
IO.Error.userError String
msg))

instance MonadFix (IOSim s) where
    mfix :: forall a. (a -> IOSim s a) -> IOSim s a
mfix a -> IOSim s a
f = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> forall a s r. (a -> IOSim s a) -> (a -> SimA s r) -> SimA s r
Fix a -> IOSim s a
f a -> SimA s r
k


instance Functor (STM s) where
    {-# INLINE fmap #-}
    fmap :: forall a b. (a -> b) -> STM s a -> STM s b
fmap a -> b
f = \STM s a
d -> forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
d (b -> StmA s r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative (STM s) where
    {-# INLINE pure #-}
    pure :: forall a. a -> STM s a
pure = \a
x -> forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> a -> StmA s r
k a
x

    {-# INLINE (<*>) #-}
    <*> :: forall a b. STM s (a -> b) -> STM s a -> STM s b
(<*>) = \STM s (a -> b)
df STM s a
dx -> forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k ->
                        forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s (a -> b)
df (\a -> b
f -> forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dx (\a
x -> b -> StmA s r
k (a -> b
f a
x)))

    {-# INLINE (*>) #-}
    *> :: forall a b. STM s a -> STM s b -> STM s b
(*>) = \STM s a
dm STM s b
dn -> forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dm (\a
_ -> forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s b
dn b -> StmA s r
k)

instance Monad (STM s) where
    return :: forall a. a -> STM s a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>=) #-}
    >>= :: forall a b. STM s a -> (a -> STM s b) -> STM s b
(>>=) = \STM s a
dm a -> STM s b
f -> forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dm (\a
m -> forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM (a -> STM s b
f a
m) b -> StmA s r
k)

    {-# INLINE (>>) #-}
    >> :: forall a b. STM s a -> STM s b -> STM s b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

#if !(MIN_VERSION_base(4,13,0))
    fail = Fail.fail
#endif

instance Fail.MonadFail (STM s) where
  fail :: forall a. String -> STM s a
fail String
msg = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> forall s a. SomeException -> StmA s a
ThrowStm (forall e. Exception e => e -> SomeException
toException (String -> ErrorCall
ErrorCall String
msg))

instance Alternative (STM s) where
    empty :: forall a. STM s a
empty = forall (m :: * -> *) a. MonadSTM m => STM m a
MonadSTM.retry
    <|> :: forall a. STM s a -> STM s a -> STM s a
(<|>) = forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
MonadSTM.orElse

instance MonadPlus (STM s) where

instance MonadFix (STM s) where
    mfix :: forall a. (a -> STM s a) -> STM s a
mfix a -> STM s a
f = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> forall a s r. (a -> STM s a) -> (a -> StmA s r) -> StmA s r
FixStm a -> STM s a
f a -> StmA s r
k

instance MonadSay (IOSim s) where
  say :: String -> IOSim s ()
say String
msg = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s b. String -> SimA s b -> SimA s b
Say String
msg (() -> SimA s r
k ())

instance MonadThrow (IOSim s) where
  throwIO :: forall e a. Exception e => e -> IOSim s a
throwIO e
e = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
_ -> forall s a. SomeException -> SimA s a
Throw (forall e. Exception e => e -> SomeException
toException e
e)

instance MonadEvaluate (IOSim s) where
  evaluate :: forall a. a -> IOSim s a
evaluate a
a = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> forall a s b. a -> (a -> SimA s b) -> SimA s b
Evaluate a
a a -> SimA s r
k

-- | Just like the IO instance, we don't actually check anything here
instance NoThunks (IOSim s a) where
  showTypeOf :: Proxy (IOSim s a) -> String
showTypeOf Proxy (IOSim s a)
_ = String
"IOSim"
  wNoThunks :: Context -> IOSim s a -> IO (Maybe ThunkInfo)
wNoThunks Context
_ctxt IOSim s a
_act = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

instance Exceptions.MonadThrow (IOSim s) where
  throwM :: forall e a. Exception e => e -> IOSim s a
throwM = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
MonadThrow.throwIO

instance MonadThrow (STM s) where
  throwIO :: forall e a. Exception e => e -> STM s a
throwIO e
e = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> forall s a. SomeException -> StmA s a
ThrowStm (forall e. Exception e => e -> SomeException
toException e
e)

  -- Since these involve re-throwing the exception and we don't provide
  -- CatchSTM at all, then we can get away with trivial versions:
  bracket :: forall a b c.
STM s a -> (a -> STM s b) -> (a -> STM s c) -> STM s c
bracket STM s a
before a -> STM s b
after a -> STM s c
thing = do
    a
a <- STM s a
before
    c
r <- a -> STM s c
thing a
a
    b
_ <- a -> STM s b
after a
a
    forall (m :: * -> *) a. Monad m => a -> m a
return c
r

  finally :: forall a b. STM s a -> STM s b -> STM s a
finally STM s a
thing STM s b
after = do
    a
r <- STM s a
thing
    b
_ <- STM s b
after
    forall (m :: * -> *) a. Monad m => a -> m a
return a
r

instance Exceptions.MonadThrow (STM s) where
  throwM :: forall e a. Exception e => e -> STM s a
throwM = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
MonadThrow.throwIO


instance MonadCatch (STM s) where

  catch :: forall e a. Exception e => STM s a -> (e -> STM s a) -> STM s a
catch STM s a
action e -> STM s a
handler = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> forall s a b.
StmA s a
-> (SomeException -> StmA s a) -> (a -> StmA s b) -> StmA s b
CatchStm (forall s a. STM s a -> StmA s a
runSTM STM s a
action) (forall s a. STM s a -> StmA s a
runSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Exception e =>
(e -> STM s a) -> SomeException -> STM s a
fromHandler e -> STM s a
handler) a -> StmA s r
k
    where
      -- Get a total handler from the given handler
      fromHandler :: Exception e => (e -> STM s a) -> SomeException -> STM s a
      fromHandler :: forall e s a.
Exception e =>
(e -> STM s a) -> SomeException -> STM s a
fromHandler e -> STM s a
h SomeException
e = case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Maybe e
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e  -- Rethrow the exception if handler does not handle it.
        Just e
e' -> e -> STM s a
h e
e'

  -- Masking is not required as STM actions are always run inside
  -- `execAtomically` and behave as if masked. Also note that the default
  -- implementation of `generalBracket` needs mask, and is part of `MonadThrow`.
  generalBracket :: forall a b c.
STM s a
-> (a -> ExitCase b -> STM s c) -> (a -> STM s b) -> STM s (b, c)
generalBracket STM s a
acquire a -> ExitCase b -> STM s c
release a -> STM s b
use = do
    a
resource <- STM s a
acquire
    b
b <- a -> STM s b
use a
resource forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
      c
_ <- a -> ExitCase b -> STM s c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
    c
c <- a -> ExitCase b -> STM s c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b)
    forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)

instance Exceptions.MonadCatch (STM s) where
  catch :: forall e a. Exception e => STM s a -> (e -> STM s a) -> STM s a
catch = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MonadThrow.catch

instance MonadCatch (IOSim s) where
  catch :: forall e a.
Exception e =>
IOSim s a -> (e -> IOSim s a) -> IOSim s a
catch IOSim s a
action e -> IOSim s a
handler =
    forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> forall a s a b.
Exception a =>
SimA s a -> (a -> SimA s a) -> (a -> SimA s b) -> SimA s b
Catch (forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
action) (forall s a. IOSim s a -> SimA s a
runIOSim forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IOSim s a
handler) a -> SimA s r
k

instance Exceptions.MonadCatch (IOSim s) where
  catch :: forall e a.
Exception e =>
IOSim s a -> (e -> IOSim s a) -> IOSim s a
catch = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MonadThrow.catch

instance MonadMask (IOSim s) where
  mask :: forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
mask (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action = do
      MaskingState
b <- forall s. IOSim s MaskingState
getMaskingStateImpl
      case MaskingState
b of
        MaskingState
Unmasked              -> forall s a. IOSim s a -> IOSim s a
block forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall s a. IOSim s a -> IOSim s a
unblock
        MaskingState
MaskedInterruptible   -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall s a. IOSim s a -> IOSim s a
block
        MaskingState
MaskedUninterruptible -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall s a. IOSim s a -> IOSim s a
blockUninterruptible

  uninterruptibleMask :: forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
uninterruptibleMask (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action = do
      MaskingState
b <- forall s. IOSim s MaskingState
getMaskingStateImpl
      case MaskingState
b of
        MaskingState
Unmasked              -> forall s a. IOSim s a -> IOSim s a
blockUninterruptible forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall s a. IOSim s a -> IOSim s a
unblock
        MaskingState
MaskedInterruptible   -> forall s a. IOSim s a -> IOSim s a
blockUninterruptible forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall s a. IOSim s a -> IOSim s a
block
        MaskingState
MaskedUninterruptible -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall s a. IOSim s a -> IOSim s a
blockUninterruptible

instance MonadMaskingState (IOSim s) where
  getMaskingState :: IOSim s MaskingState
getMaskingState = forall s. IOSim s MaskingState
getMaskingStateImpl
  interruptible :: forall a. IOSim s a -> IOSim s a
interruptible IOSim s a
action = do
      MaskingState
b <- forall s. IOSim s MaskingState
getMaskingStateImpl
      case MaskingState
b of
        MaskingState
Unmasked              -> IOSim s a
action
        MaskingState
MaskedInterruptible   -> forall s a. IOSim s a -> IOSim s a
unblock IOSim s a
action
        MaskingState
MaskedUninterruptible -> IOSim s a
action

instance Exceptions.MonadMask (IOSim s) where
  mask :: forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
mask                = forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.mask
  uninterruptibleMask :: forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
uninterruptibleMask = forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.uninterruptibleMask

  generalBracket :: forall a b c.
IOSim s a
-> (a -> ExitCase b -> IOSim s c)
-> (a -> IOSim s b)
-> IOSim s (b, c)
generalBracket IOSim s a
acquire a -> ExitCase b -> IOSim s c
release a -> IOSim s b
use =
    forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IOSim s a -> IOSim s a
unmasked -> do
      a
resource <- IOSim s a
acquire
      b
b <- forall a. IOSim s a -> IOSim s a
unmasked (a -> IOSim s b
use a
resource) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
        c
_ <- a -> ExitCase b -> IOSim s c
release a
resource (forall a. SomeException -> ExitCase a
Exceptions.ExitCaseException SomeException
e)
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
      c
c <- a -> ExitCase b -> IOSim s c
release a
resource (forall a. a -> ExitCase a
Exceptions.ExitCaseSuccess b
b)
      forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)

instance NoThunks a => NoThunks (StrictTVar (IOSim s) a) where
  showTypeOf :: Proxy (StrictTVar (IOSim s) a) -> String
showTypeOf Proxy (StrictTVar (IOSim s) a)
_ = String
"StrictTVar IOSim"
  wNoThunks :: Context -> StrictTVar (IOSim s) a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt StrictTVar (IOSim s) a
tvar = do
      a
a <- forall s a. ST s a -> IO a
unsafeSTToIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. ST s a -> ST s a
lazyToStrictST forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. TVar s a -> ST s a
execReadTVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
StrictTVar.toLazyTVar
                        forall a b. (a -> b) -> a -> b
$ StrictTVar (IOSim s) a
tvar
      forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt a
a

execReadTVar :: TVar s a -> ST s a
execReadTVar :: forall s a. TVar s a -> ST s a
execReadTVar TVar{STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent :: STRef s a
tvarCurrent} = forall s a. STRef s a -> ST s a
readSTRef STRef s a
tvarCurrent
{-# INLINE execReadTVar #-}

getMaskingStateImpl :: IOSim s MaskingState
unblock, block, blockUninterruptible :: IOSim s a -> IOSim s a

getMaskingStateImpl :: forall s. IOSim s MaskingState
getMaskingStateImpl    = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim  forall s b. (MaskingState -> SimA s b) -> SimA s b
GetMaskState
unblock :: forall s a. IOSim s a -> IOSim s a
unblock              IOSim s a
a = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (forall s a b.
MaskingState -> IOSim s a -> (a -> SimA s b) -> SimA s b
SetMaskState MaskingState
Unmasked IOSim s a
a)
block :: forall s a. IOSim s a -> IOSim s a
block                IOSim s a
a = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (forall s a b.
MaskingState -> IOSim s a -> (a -> SimA s b) -> SimA s b
SetMaskState MaskingState
MaskedInterruptible IOSim s a
a)
blockUninterruptible :: forall s a. IOSim s a -> IOSim s a
blockUninterruptible IOSim s a
a = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (forall s a b.
MaskingState -> IOSim s a -> (a -> SimA s b) -> SimA s b
SetMaskState MaskingState
MaskedUninterruptible IOSim s a
a)

instance MonadThread (IOSim s) where
  type ThreadId (IOSim s) = IOSimThreadId
  myThreadId :: IOSim s (ThreadId (IOSim s))
myThreadId       = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \ThreadId (IOSim s) -> SimA s r
k -> forall s b. (IOSimThreadId -> SimA s b) -> SimA s b
GetThreadId ThreadId (IOSim s) -> SimA s r
k
  labelThread :: ThreadId (IOSim s) -> String -> IOSim s ()
labelThread ThreadId (IOSim s)
t String
l  = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s b. IOSimThreadId -> String -> SimA s b -> SimA s b
LabelThread ThreadId (IOSim s)
t String
l (() -> SimA s r
k ())

instance MonadFork (IOSim s) where
  forkIO :: IOSim s () -> IOSim s (ThreadId (IOSim s))
forkIO IOSim s ()
task        = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \ThreadId (IOSim s) -> SimA s r
k -> forall s b. IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
Fork IOSim s ()
task ThreadId (IOSim s) -> SimA s r
k
  forkOn :: Int -> IOSim s () -> IOSim s (ThreadId (IOSim s))
forkOn Int
_ IOSim s ()
task      = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \ThreadId (IOSim s) -> SimA s r
k -> forall s b. IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
Fork IOSim s ()
task ThreadId (IOSim s) -> SimA s r
k
  forkIOWithUnmask :: ((forall a. IOSim s a -> IOSim s a) -> IOSim s ())
-> IOSim s (ThreadId (IOSim s))
forkIOWithUnmask (forall a. IOSim s a -> IOSim s a) -> IOSim s ()
f = forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO ((forall a. IOSim s a -> IOSim s a) -> IOSim s ()
f forall s a. IOSim s a -> IOSim s a
unblock)
  throwTo :: forall e. Exception e => ThreadId (IOSim s) -> e -> IOSim s ()
throwTo ThreadId (IOSim s)
tid e
e      = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s a. SomeException -> IOSimThreadId -> SimA s a -> SimA s a
ThrowTo (forall e. Exception e => e -> SomeException
toException e
e) ThreadId (IOSim s)
tid (() -> SimA s r
k ())
  yield :: IOSim s ()
yield              = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s a. SimA s a -> SimA s a
YieldSim (() -> SimA s r
k ())

instance MonadTest (IOSim s) where
  exploreRaces :: IOSim s ()
exploreRaces       = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s a. SimA s a -> SimA s a
ExploreRaces (() -> SimA s r
k ())

instance MonadSay (STMSim s) where
  say :: String -> STMSim s ()
say String
msg = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> forall s b. String -> StmA s b -> StmA s b
SayStm String
msg (() -> StmA s r
k ())


instance MonadLabelledSTM (IOSim s) where
  labelTVar :: forall a. TVar (IOSim s) a -> String -> STM (IOSim s) ()
labelTVar TVar (IOSim s) a
tvar String
label = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> forall s a b. String -> TVar s a -> StmA s b -> StmA s b
LabelTVar String
label TVar (IOSim s) a
tvar (() -> StmA s r
k ())
  labelTVarIO :: forall a. TVar (IOSim s) a -> String -> IOSim s ()
labelTVarIO TVar (IOSim s) a
tvar String
label = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k ->
                                   forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ( forall s a. ST s a -> ST s a
lazyToStrictST forall a b. (a -> b) -> a -> b
$
                                            forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall s a. TVar s a -> STRef s (Maybe String)
tvarLabel TVar (IOSim s) a
tvar) forall a b. (a -> b) -> a -> b
$! (forall a. a -> Maybe a
Just String
label)
                                          ) () -> SimA s r
k
  labelTQueue :: forall a. TQueue (IOSim s) a -> String -> STM (IOSim s) ()
labelTQueue  = forall (m :: * -> *) a.
MonadLabelledSTM m =>
TQueueDefault m a -> String -> STM m ()
labelTQueueDefault
  labelTBQueue :: forall a. TBQueue (IOSim s) a -> String -> STM (IOSim s) ()
labelTBQueue = forall (m :: * -> *) a.
MonadLabelledSTM m =>
TBQueueDefault m a -> String -> STM m ()
labelTBQueueDefault

instance MonadSTM (IOSim s) where
  type STM       (IOSim s) = STM s
  type TVar      (IOSim s) = TVar s
  type TMVar     (IOSim s) = TMVarDefault (IOSim s)
  type TQueue    (IOSim s) = TQueueDefault (IOSim s)
  type TBQueue   (IOSim s) = TBQueueDefault (IOSim s)
  type TArray    (IOSim s) = TArrayDefault (IOSim s)
  type TSem      (IOSim s) = TSemDefault (IOSim s)
  type TChan     (IOSim s) = TChanDefault (IOSim s)

  atomically :: forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
atomically STM (IOSim s) a
action = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> forall s a b. STM s a -> (a -> SimA s b) -> SimA s b
Atomically STM (IOSim s) a
action a -> SimA s r
k

  newTVar :: forall a. a -> STM (IOSim s) (TVar (IOSim s) a)
newTVar         a
x = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \TVar s a -> StmA s r
k -> forall a s b.
Maybe String -> a -> (TVar s a -> StmA s b) -> StmA s b
NewTVar forall a. Maybe a
Nothing a
x TVar s a -> StmA s r
k
  readTVar :: forall a. TVar (IOSim s) a -> STM (IOSim s) a
readTVar   TVar (IOSim s) a
tvar   = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> forall s a b. TVar s a -> (a -> StmA s b) -> StmA s b
ReadTVar TVar (IOSim s) a
tvar a -> StmA s r
k
  writeTVar :: forall a. TVar (IOSim s) a -> a -> STM (IOSim s) ()
writeTVar  TVar (IOSim s) a
tvar a
x = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> forall s a b. TVar s a -> a -> StmA s b -> StmA s b
WriteTVar TVar (IOSim s) a
tvar a
x (() -> StmA s r
k ())
  retry :: forall a. STM (IOSim s) a
retry             = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> forall s b. StmA s b
Retry
  orElse :: forall a. STM (IOSim s) a -> STM (IOSim s) a -> STM (IOSim s) a
orElse        STM (IOSim s) a
a STM (IOSim s) a
b = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> forall s a b. StmA s a -> StmA s a -> (a -> StmA s b) -> StmA s b
OrElse (forall s a. STM s a -> StmA s a
runSTM STM (IOSim s) a
a) (forall s a. STM s a -> StmA s a
runSTM STM (IOSim s) a
b) a -> StmA s r
k

  newTMVar :: forall a. a -> STM (IOSim s) (TMVar (IOSim s) a)
newTMVar          = forall (m :: * -> *) a. MonadSTM m => a -> STM m (TMVarDefault m a)
MonadSTM.newTMVarDefault
  newEmptyTMVar :: forall a. STM (IOSim s) (TMVar (IOSim s) a)
newEmptyTMVar     = forall (m :: * -> *) a. MonadSTM m => STM m (TMVarDefault m a)
MonadSTM.newEmptyTMVarDefault
  takeTMVar :: forall a. TMVar (IOSim s) a -> STM (IOSim s) a
takeTMVar         = forall (m :: * -> *) a. MonadSTM m => TMVarDefault m a -> STM m a
MonadSTM.takeTMVarDefault
  tryTakeTMVar :: forall a. TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
tryTakeTMVar      = forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m (Maybe a)
MonadSTM.tryTakeTMVarDefault
  putTMVar :: forall a. TMVar (IOSim s) a -> a -> STM (IOSim s) ()
putTMVar          = forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m ()
MonadSTM.putTMVarDefault
  tryPutTMVar :: forall a. TMVar (IOSim s) a -> a -> STM (IOSim s) Bool
tryPutTMVar       = forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m Bool
MonadSTM.tryPutTMVarDefault
  readTMVar :: forall a. TMVar (IOSim s) a -> STM (IOSim s) a
readTMVar         = forall (m :: * -> *) a. MonadSTM m => TMVarDefault m a -> STM m a
MonadSTM.readTMVarDefault
  tryReadTMVar :: forall a. TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
tryReadTMVar      = forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m (Maybe a)
MonadSTM.tryReadTMVarDefault
  swapTMVar :: forall a. TMVar (IOSim s) a -> a -> STM (IOSim s) a
swapTMVar         = forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m a
MonadSTM.swapTMVarDefault
  isEmptyTMVar :: forall a. TMVar (IOSim s) a -> STM (IOSim s) Bool
isEmptyTMVar      = forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m Bool
MonadSTM.isEmptyTMVarDefault

  newTQueue :: forall a. STM (IOSim s) (TQueue (IOSim s) a)
newTQueue         = forall (m :: * -> *) a. MonadSTM m => STM m (TQueueDefault m a)
newTQueueDefault
  readTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) a
readTQueue        = forall (m :: * -> *) a. MonadSTM m => TQueueDefault m a -> STM m a
readTQueueDefault
  tryReadTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
tryReadTQueue     = forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault
  peekTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) a
peekTQueue        = forall (m :: * -> *) a. MonadSTM m => TQueueDefault m a -> STM m a
peekTQueueDefault
  tryPeekTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
tryPeekTQueue     = forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m (Maybe a)
tryPeekTQueueDefault
  flushTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) [a]
flushTQueue       = forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m [a]
flushTQueueDefault
  writeTQueue :: forall a. TQueue (IOSim s) a -> a -> STM (IOSim s) ()
writeTQueue       = forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> a -> STM m ()
writeTQueueDefault
  isEmptyTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) Bool
isEmptyTQueue     = forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m Bool
isEmptyTQueueDefault
  unGetTQueue :: forall a. TQueue (IOSim s) a -> a -> STM (IOSim s) ()
unGetTQueue       = forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> a -> STM m ()
unGetTQueueDefault

  newTBQueue :: forall a. Natural -> STM (IOSim s) (TBQueue (IOSim s) a)
newTBQueue        = forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (TBQueueDefault m a)
newTBQueueDefault
  readTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) a
readTBQueue       = forall (m :: * -> *) a. MonadSTM m => TBQueueDefault m a -> STM m a
readTBQueueDefault
  tryReadTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
tryReadTBQueue    = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault
  peekTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) a
peekTBQueue       = forall (m :: * -> *) a. MonadSTM m => TBQueueDefault m a -> STM m a
peekTBQueueDefault
  tryPeekTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
tryPeekTBQueue    = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m (Maybe a)
tryPeekTBQueueDefault
  flushTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) [a]
flushTBQueue      = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m [a]
flushTBQueueDefault
  writeTBQueue :: forall a. TBQueue (IOSim s) a -> a -> STM (IOSim s) ()
writeTBQueue      = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> a -> STM m ()
writeTBQueueDefault
  lengthTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) Natural
lengthTBQueue     = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Natural
lengthTBQueueDefault
  isEmptyTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) Bool
isEmptyTBQueue    = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isEmptyTBQueueDefault
  isFullTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) Bool
isFullTBQueue     = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isFullTBQueueDefault
  unGetTBQueue :: forall a. TBQueue (IOSim s) a -> a -> STM (IOSim s) ()
unGetTBQueue      = forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> a -> STM m ()
unGetTBQueueDefault

  newTSem :: Integer -> STM (IOSim s) (TSem (IOSim s))
newTSem           = forall (m :: * -> *).
MonadSTM m =>
Integer -> STM m (TSemDefault m)
MonadSTM.newTSemDefault
  waitTSem :: TSem (IOSim s) -> STM (IOSim s) ()
waitTSem          = forall (m :: * -> *). MonadSTM m => TSemDefault m -> STM m ()
MonadSTM.waitTSemDefault
  signalTSem :: TSem (IOSim s) -> STM (IOSim s) ()
signalTSem        = forall (m :: * -> *). MonadSTM m => TSemDefault m -> STM m ()
MonadSTM.signalTSemDefault
  signalTSemN :: Natural -> TSem (IOSim s) -> STM (IOSim s) ()
signalTSemN       = forall (m :: * -> *).
MonadSTM m =>
Natural -> TSemDefault m -> STM m ()
MonadSTM.signalTSemNDefault

  newTChan :: forall a. STM (IOSim s) (TChan (IOSim s) a)
newTChan          = forall (m :: * -> *) a. MonadSTM m => STM m (TChanDefault m a)
MonadSTM.newTChanDefault
  newBroadcastTChan :: forall a. STM (IOSim s) (TChan (IOSim s) a)
newBroadcastTChan = forall (m :: * -> *) a. MonadSTM m => STM m (TChanDefault m a)
MonadSTM.newBroadcastTChanDefault
  writeTChan :: forall a. TChan (IOSim s) a -> a -> STM (IOSim s) ()
writeTChan        = forall (m :: * -> *) a.
MonadSTM m =>
TChanDefault m a -> a -> STM m ()
MonadSTM.writeTChanDefault
  readTChan :: forall a. TChan (IOSim s) a -> STM (IOSim s) a
readTChan         = forall (m :: * -> *) a. MonadSTM m => TChanDefault m a -> STM m a
MonadSTM.readTChanDefault
  tryReadTChan :: forall a. TChan (IOSim s) a -> STM (IOSim s) (Maybe a)
tryReadTChan      = forall (m :: * -> *) a.
MonadSTM m =>
TChanDefault m a -> STM m (Maybe a)
MonadSTM.tryReadTChanDefault
  peekTChan :: forall a. TChan (IOSim s) a -> STM (IOSim s) a
peekTChan         = forall (m :: * -> *) a. MonadSTM m => TChanDefault m a -> STM m a
MonadSTM.peekTChanDefault
  tryPeekTChan :: forall a. TChan (IOSim s) a -> STM (IOSim s) (Maybe a)
tryPeekTChan      = forall (m :: * -> *) a.
MonadSTM m =>
TChanDefault m a -> STM m (Maybe a)
MonadSTM.tryPeekTChanDefault
  dupTChan :: forall a. TChan (IOSim s) a -> STM (IOSim s) (TChan (IOSim s) a)
dupTChan          = forall (m :: * -> *) a.
MonadSTM m =>
TChanDefault m a -> STM m (TChanDefault m a)
MonadSTM.dupTChanDefault
  unGetTChan :: forall a. TChan (IOSim s) a -> a -> STM (IOSim s) ()
unGetTChan        = forall (m :: * -> *) a.
MonadSTM m =>
TChanDefault m a -> a -> STM m ()
MonadSTM.unGetTChanDefault
  isEmptyTChan :: forall a. TChan (IOSim s) a -> STM (IOSim s) Bool
isEmptyTChan      = forall (m :: * -> *) a.
MonadSTM m =>
TChanDefault m a -> STM m Bool
MonadSTM.isEmptyTChanDefault
  cloneTChan :: forall a. TChan (IOSim s) a -> STM (IOSim s) (TChan (IOSim s) a)
cloneTChan        = forall (m :: * -> *) a.
MonadSTM m =>
TChanDefault m a -> STM m (TChanDefault m a)
MonadSTM.cloneTChanDefault

instance MonadInspectSTM (IOSim s) where
  type InspectMonad (IOSim s) = ST s
  inspectTVar :: forall (proxy :: (* -> *) -> *) a.
proxy (IOSim s) -> TVar (IOSim s) a -> InspectMonad (IOSim s) a
inspectTVar  proxy (IOSim s)
_                 TVar { STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent }  = forall s a. STRef s a -> ST s a
readSTRef STRef s a
tvarCurrent
  inspectTMVar :: forall (proxy :: (* -> *) -> *) a.
proxy (IOSim s)
-> TMVar (IOSim s) a -> InspectMonad (IOSim s) (Maybe a)
inspectTMVar proxy (IOSim s)
_ (MonadSTM.TMVar TVar { STRef s (Maybe a)
tvarCurrent :: STRef s (Maybe a)
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent }) = forall s a. STRef s a -> ST s a
readSTRef STRef s (Maybe a)
tvarCurrent

-- | This instance adds a trace when a variable was written, just after the
-- stm transaction was committed.
--
-- Traces the first value using dynamic tracing, like 'traceM' does, i.e.  with
-- 'EventDynamic'; the string is traced using 'EventSay'.
--
instance MonadTraceSTM (IOSim s) where
  traceTVar :: forall (proxy :: (* -> *) -> *) a.
proxy (IOSim s)
-> TVar (IOSim s) a
-> (Maybe a -> a -> InspectMonad (IOSim s) TraceValue)
-> STM (IOSim s) ()
traceTVar proxy (IOSim s)
_ TVar (IOSim s) a
tvar Maybe a -> a -> InspectMonad (IOSim s) TraceValue
f = forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> forall s a b.
TVar s a
-> (Maybe a -> a -> ST s TraceValue) -> StmA s b -> StmA s b
TraceTVar TVar (IOSim s) a
tvar Maybe a -> a -> InspectMonad (IOSim s) TraceValue
f (() -> StmA s r
k ())
  traceTVarIO :: forall a.
TVar (IOSim s) a
-> (Maybe a -> a -> InspectMonad (IOSim s) TraceValue)
-> IOSim s ()
traceTVarIO TVar (IOSim s) a
tvar Maybe a -> a -> InspectMonad (IOSim s) TraceValue
f = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k ->
                               forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ( forall s a. ST s a -> ST s a
lazyToStrictST forall a b. (a -> b) -> a -> b
$
                                        forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall s a.
TVar s a -> STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace TVar (IOSim s) a
tvar) forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just Maybe a -> a -> InspectMonad (IOSim s) TraceValue
f
                                      ) () -> SimA s r
k
  traceTQueue :: forall (proxy :: (* -> *) -> *) a.
proxy (IOSim s)
-> TQueue (IOSim s) a
-> (Maybe [a] -> [a] -> InspectMonad (IOSim s) TraceValue)
-> STM (IOSim s) ()
traceTQueue  = forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
-> STM m ()
traceTQueueDefault
  traceTBQueue :: forall (proxy :: (* -> *) -> *) a.
proxy (IOSim s)
-> TBQueue (IOSim s) a
-> (Maybe [a] -> [a] -> InspectMonad (IOSim s) TraceValue)
-> STM (IOSim s) ()
traceTBQueue = forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TBQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
-> STM m ()
traceTBQueueDefault


instance MonadMVar (IOSim s) where
  type MVar (IOSim s) = MVarDefault (IOSim s)
  newEmptyMVar :: forall a. IOSim s (MVar (IOSim s) a)
newEmptyMVar = forall (m :: * -> *) a. MonadSTM m => m (MVarDefault m a)
newEmptyMVarDefault
  newMVar :: forall a. a -> IOSim s (MVar (IOSim s) a)
newMVar      = forall (m :: * -> *) a. MonadSTM m => a -> m (MVarDefault m a)
newMVarDefault
  takeMVar :: forall a. MVar (IOSim s) a -> IOSim s a
takeMVar     = forall (m :: * -> *) a.
(MonadMask m, MonadSTM m,
 forall x tvar. (tvar ~ TVar m x) => Eq tvar) =>
MVarDefault m a -> m a
takeMVarDefault
  putMVar :: forall a. MVar (IOSim s) a -> a -> IOSim s ()
putMVar      = forall (m :: * -> *) a.
(MonadMask m, MonadSTM m,
 forall x tvar. (tvar ~ TVar m x) => Eq tvar) =>
MVarDefault m a -> a -> m ()
putMVarDefault
  tryTakeMVar :: forall a. MVar (IOSim s) a -> IOSim s (Maybe a)
tryTakeMVar  = forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> m (Maybe a)
tryTakeMVarDefault
  tryPutMVar :: forall a. MVar (IOSim s) a -> a -> IOSim s Bool
tryPutMVar   = forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> a -> m Bool
tryPutMVarDefault
  readMVar :: forall a. MVar (IOSim s) a -> IOSim s a
readMVar     = forall (m :: * -> *) a.
(MonadSTM m, MonadMask m,
 forall x tvar. (tvar ~ TVar m x) => Eq tvar) =>
MVarDefault m a -> m a
readMVarDefault
  tryReadMVar :: forall a. MVar (IOSim s) a -> IOSim s (Maybe a)
tryReadMVar  = forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> m (Maybe a)
tryReadMVarDefault
  isEmptyMVar :: forall a. MVar (IOSim s) a -> IOSim s Bool
isEmptyMVar  = forall (m :: * -> *) a. MonadSTM m => MVarDefault m a -> m Bool
isEmptyMVarDefault

instance MonadInspectMVar (IOSim s) where
  type InspectMVarMonad (IOSim s) = ST s
  inspectMVar :: forall (proxy :: (* -> *) -> *) a.
proxy (IOSim s)
-> MVar (IOSim s) a -> InspectMVarMonad (IOSim s) (Maybe a)
inspectMVar proxy (IOSim s)
p (MVar TVar (IOSim s) (MVarState (IOSim s) a)
tvar) = do
      MVarState (IOSim s) a
st <- forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadInspectSTM m =>
proxy m -> TVar m a -> InspectMonad m a
inspectTVar proxy (IOSim s)
p TVar (IOSim s) (MVarState (IOSim s) a)
tvar
      case MVarState (IOSim s) a
st of
        MVarEmpty Deque (TVar (IOSim s) (Maybe a))
_ Deque (TVar (IOSim s) (Maybe a))
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        MVarFull a
x Deque (a, TVar (IOSim s) Bool)
_  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
x)

data Async s a = Async !IOSimThreadId (STM s (Either SomeException a))

instance Eq (Async s a) where
    Async IOSimThreadId
tid STM s (Either SomeException a)
_ == :: Async s a -> Async s a -> Bool
== Async IOSimThreadId
tid' STM s (Either SomeException a)
_ = IOSimThreadId
tid forall a. Eq a => a -> a -> Bool
== IOSimThreadId
tid'

instance Ord (Async s a) where
    compare :: Async s a -> Async s a -> Ordering
compare (Async IOSimThreadId
tid STM s (Either SomeException a)
_) (Async IOSimThreadId
tid' STM s (Either SomeException a)
_) = forall a. Ord a => a -> a -> Ordering
compare IOSimThreadId
tid IOSimThreadId
tid'

instance Functor (Async s) where
  fmap :: forall a b. (a -> b) -> Async s a -> Async s b
fmap a -> b
f (Async IOSimThreadId
tid STM s (Either SomeException a)
a) = forall s a.
IOSimThreadId -> STM s (Either SomeException a) -> Async s a
Async IOSimThreadId
tid (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s (Either SomeException a)
a)

instance MonadAsync (IOSim s) where
  type Async (IOSim s) = Async s

  async :: forall a. IOSim s a -> IOSim s (Async (IOSim s) a)
async IOSim s a
action = do
    TMVarDefault (IOSim s) (Either SomeException a)
var <- forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
MonadSTM.newEmptyTMVarIO
    IOSimThreadId
tid <- forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall b. IOSim s b -> IOSim s b
restore ->
             forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (forall b. IOSim s b -> IOSim s b
restore IOSim s a
action)
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
MonadSTM.atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
MonadSTM.putTMVar TMVarDefault (IOSim s) (Either SomeException a)
var
    forall (m :: * -> *) a.
MonadLabelledSTM m =>
TMVar m a -> String -> m ()
MonadSTM.labelTMVarIO TMVarDefault (IOSim s) (Either SomeException a)
var (String
"async-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOSimThreadId
tid)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a.
IOSimThreadId -> STM s (Either SomeException a) -> Async s a
Async IOSimThreadId
tid (forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
MonadSTM.readTMVar TMVarDefault (IOSim s) (Either SomeException a)
var))

  asyncOn :: forall a. Int -> IOSim s a -> IOSim s (Async (IOSim s) a)
asyncOn Int
_  = forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async
  asyncBound :: forall a. IOSim s a -> IOSim s (Async (IOSim s) a)
asyncBound = forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async

  asyncThreadId :: forall a. Async (IOSim s) a -> ThreadId (IOSim s)
asyncThreadId (Async IOSimThreadId
tid STM s (Either SomeException a)
_) = IOSimThreadId
tid

  waitCatchSTM :: forall a.
Async (IOSim s) a -> STM (IOSim s) (Either SomeException a)
waitCatchSTM (Async IOSimThreadId
_ STM s (Either SomeException a)
w) = STM s (Either SomeException a)
w
  pollSTM :: forall a.
Async (IOSim s) a -> STM (IOSim s) (Maybe (Either SomeException a))
pollSTM      (Async IOSimThreadId
_ STM s (Either SomeException a)
w) = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s (Either SomeException a)
w) forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`MonadSTM.orElse` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  cancel :: forall a. Async (IOSim s) a -> IOSim s ()
cancel a :: Async (IOSim s) a
a@(Async IOSimThreadId
tid STM s (Either SomeException a)
_) = forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo IOSimThreadId
tid AsyncCancelled
AsyncCancelled forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async (IOSim s) a
a
  cancelWith :: forall e a. Exception e => Async (IOSim s) a -> e -> IOSim s ()
cancelWith a :: Async (IOSim s) a
a@(Async IOSimThreadId
tid STM s (Either SomeException a)
_) e
e = forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo IOSimThreadId
tid e
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async (IOSim s) a
a

  asyncWithUnmask :: forall a.
((forall b. IOSim s b -> IOSim s b) -> IOSim s a)
-> IOSim s (Async (IOSim s) a)
asyncWithUnmask (forall b. IOSim s b -> IOSim s b) -> IOSim s a
k = forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async ((forall b. IOSim s b -> IOSim s b) -> IOSim s a
k forall s a. IOSim s a -> IOSim s a
unblock)
  asyncOnWithUnmask :: forall a.
Int
-> ((forall b. IOSim s b -> IOSim s b) -> IOSim s a)
-> IOSim s (Async (IOSim s) a)
asyncOnWithUnmask Int
_ (forall b. IOSim s b -> IOSim s b) -> IOSim s a
k = forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async ((forall b. IOSim s b -> IOSim s b) -> IOSim s a
k forall s a. IOSim s a -> IOSim s a
unblock)

instance MonadST (IOSim s) where
  withLiftST :: forall b. (forall s. (forall a. ST s a -> IOSim s a) -> b) -> b
withLiftST forall s. (forall a. ST s a -> IOSim s a) -> b
f = forall s. (forall a. ST s a -> IOSim s a) -> b
f forall s a. ST s a -> IOSim s a
liftST

-- | Lift an 'StrictST.ST' computation to 'IOSim'.
--
-- Note: you can use 'MonadST' to lift 'StrictST.ST' computations, this is just
-- a more convenient function just for 'IOSim'.
liftST :: StrictST.ST s a -> IOSim s a
liftST :: forall s a. ST s a -> IOSim s a
liftST ST s a
action = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ST s a
action a -> SimA s r
k

instance MonadMonotonicTimeNSec (IOSim s) where
  getMonotonicTimeNSec :: IOSim s Word64
getMonotonicTimeNSec = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \Word64 -> SimA s r
k -> forall s b. (Time -> SimA s b) -> SimA s b
GetMonoTime (Word64 -> SimA s r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> Word64
conv)
    where
      -- convert time in picoseconds to nanoseconds
      conv :: Time -> Word64
      conv :: Time -> Word64
conv (Time DiffTime
d) = forall a b. (Integral a, Num b) => a -> b
fromIntegral (DiffTime -> Integer
diffTimeToPicoseconds DiffTime
d forall a. Integral a => a -> a -> a
`div` Integer
1_000)

instance MonadMonotonicTime (IOSim s) where
  getMonotonicTime :: IOSim s Time
getMonotonicTime = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \Time -> SimA s r
k -> forall s b. (Time -> SimA s b) -> SimA s b
GetMonoTime Time -> SimA s r
k

instance MonadTime (IOSim s) where
  getCurrentTime :: IOSim s UTCTime
getCurrentTime   = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \UTCTime -> SimA s r
k -> forall s b. (UTCTime -> SimA s b) -> SimA s b
GetWallTime UTCTime -> SimA s r
k

-- | Set the current wall clock time for the thread's clock domain.
--
setCurrentTime :: UTCTime -> IOSim s ()
setCurrentTime :: forall s. UTCTime -> IOSim s ()
setCurrentTime UTCTime
t = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s b. UTCTime -> SimA s b -> SimA s b
SetWallTime UTCTime
t (() -> SimA s r
k ())

-- | Put the thread into a new wall clock domain, not shared with the parent
-- thread. Changing the wall clock time in the new clock domain will not affect
-- the other clock of other threads. All threads forked by this thread from
-- this point onwards will share the new clock domain.
--
unshareClock :: IOSim s ()
unshareClock :: forall s. IOSim s ()
unshareClock = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s a. SimA s a -> SimA s a
UnshareClock (() -> SimA s r
k ())

instance MonadDelay (IOSim s) where
  -- Use optimized IOSim primitive
  threadDelay :: Int -> IOSim s ()
threadDelay Int
d =
    forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s b. DiffTime -> SimA s b -> SimA s b
ThreadDelay (Int -> DiffTime
SI.microsecondsAsIntToDiffTime Int
d)
                                        (() -> SimA s r
k ())

instance SI.MonadDelay (IOSim s) where
  threadDelay :: DiffTime -> IOSim s ()
threadDelay DiffTime
d =
    forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s b. DiffTime -> SimA s b -> SimA s b
ThreadDelay DiffTime
d (() -> SimA s r
k ())

data Timeout s = Timeout !(TVar s TimeoutState) !TimeoutId
               -- ^ a timeout
               | NegativeTimeout !TimeoutId
               -- ^ a negative timeout

newTimeout :: DiffTime -> IOSim s (Timeout s)
newTimeout :: forall s. DiffTime -> IOSim s (Timeout s)
newTimeout DiffTime
d = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \Timeout s -> SimA s r
k -> forall s b. DiffTime -> (Timeout s -> SimA s b) -> SimA s b
NewTimeout DiffTime
d Timeout s -> SimA s r
k

readTimeout :: Timeout s -> STM s TimeoutState
readTimeout :: forall s. Timeout s -> STM s TimeoutState
readTimeout (Timeout TVar s TimeoutState
var TimeoutId
_key)     = forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
MonadSTM.readTVar TVar s TimeoutState
var
readTimeout (NegativeTimeout TimeoutId
_key) = forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeoutState
TimeoutCancelled

cancelTimeout :: Timeout s -> IOSim s ()
cancelTimeout :: forall s. Timeout s -> IOSim s ()
cancelTimeout Timeout s
t = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s b. Timeout s -> SimA s b -> SimA s b
CancelTimeout Timeout s
t (() -> SimA s r
k ())

awaitTimeout :: Timeout s -> STM s Bool
awaitTimeout :: forall s. Timeout s -> STM s Bool
awaitTimeout Timeout s
t  = do TimeoutState
s <- forall s. Timeout s -> STM s TimeoutState
readTimeout Timeout s
t
                     case TimeoutState
s of
                       TimeoutState
TimeoutPending   -> forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                       TimeoutState
TimeoutFired     -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                       TimeoutState
TimeoutCancelled -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

instance MonadTimer (IOSim s) where
  timeout :: forall a. Int -> IOSim s a -> IOSim s (Maybe a)
timeout Int
d IOSim s a
action
    | Int
d forall a. Ord a => a -> a -> Bool
<  Int
0 = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOSim s a
action
    | Int
d forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    | Bool
otherwise = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \Maybe a -> SimA s r
k -> forall s a b.
DiffTime -> SimA s a -> (Maybe a -> SimA s b) -> SimA s b
StartTimeout DiffTime
d' (forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
action) Maybe a -> SimA s r
k
        where
          d' :: DiffTime
d' = Int -> DiffTime
SI.microsecondsAsIntToDiffTime Int
d

  registerDelay :: Int -> IOSim s (TVar (IOSim s) Bool)
registerDelay Int
d = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \TVar (IOSim s) Bool -> SimA s r
k -> forall s b. DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b
RegisterDelay DiffTime
d' TVar (IOSim s) Bool -> SimA s r
k
    where
      d' :: DiffTime
d' = Int -> DiffTime
SI.microsecondsAsIntToDiffTime Int
d

instance SI.MonadTimer (IOSim s) where
  timeout :: forall a. DiffTime -> IOSim s a -> IOSim s (Maybe a)
timeout DiffTime
d IOSim s a
action
    | DiffTime
d forall a. Ord a => a -> a -> Bool
<  DiffTime
0 = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOSim s a
action
    | DiffTime
d forall a. Eq a => a -> a -> Bool
== DiffTime
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    | Bool
otherwise = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \Maybe a -> SimA s r
k -> forall s a b.
DiffTime -> SimA s a -> (Maybe a -> SimA s b) -> SimA s b
StartTimeout DiffTime
d (forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
action) Maybe a -> SimA s r
k

  registerDelay :: DiffTime -> IOSim s (TVar (IOSim s) Bool)
registerDelay DiffTime
d = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \TVar (IOSim s) Bool -> SimA s r
k -> forall s b. DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b
RegisterDelay DiffTime
d TVar (IOSim s) Bool -> SimA s r
k
  registerDelayCancellable :: DiffTime -> IOSim s (STM (IOSim s) TimeoutState, IOSim s ())
registerDelayCancellable DiffTime
d = do
    Timeout s
t <- forall s. DiffTime -> IOSim s (Timeout s)
newTimeout DiffTime
d
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. Timeout s -> STM s TimeoutState
readTimeout Timeout s
t, forall s. Timeout s -> IOSim s ()
cancelTimeout Timeout s
t)

newtype TimeoutException = TimeoutException TimeoutId deriving TimeoutException -> TimeoutException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeoutException -> TimeoutException -> Bool
$c/= :: TimeoutException -> TimeoutException -> Bool
== :: TimeoutException -> TimeoutException -> Bool
$c== :: TimeoutException -> TimeoutException -> Bool
Eq

instance Show TimeoutException where
    show :: TimeoutException -> String
show (TimeoutException TimeoutId
tmid) = String
"<<timeout " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TimeoutId
tmid forall a. [a] -> [a] -> [a]
++ String
" >>"

instance Exception TimeoutException where
  toException :: TimeoutException -> SomeException
toException   = forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe TimeoutException
fromException = forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException

-- | Wrapper for Eventlog events so they can be retrieved from the trace with
-- 'selectTraceEventsDynamic'.
newtype EventlogEvent = EventlogEvent String

-- | Wrapper for Eventlog markers so they can be retrieved from the trace with
-- 'selectTraceEventsDynamic'.
newtype EventlogMarker = EventlogMarker String

instance MonadEventlog (IOSim s) where
  traceEventIO :: String -> IOSim s ()
traceEventIO = forall a s. Typeable a => a -> IOSim s ()
traceM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EventlogEvent
EventlogEvent
  traceMarkerIO :: String -> IOSim s ()
traceMarkerIO = forall a s. Typeable a => a -> IOSim s ()
traceM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EventlogMarker
EventlogMarker

-- | 'Trace' is a recursive data type, it is the trace of a 'IOSim'
-- computation.  The trace will contain information about thread scheduling,
-- blocking on 'TVar's, and other internal state changes of 'IOSim'.  More
-- importantly it also supports traces generated by the computation with 'say'
-- (which corresponds to using 'putStrLn' in 'IO'), 'traceEventM', or
-- dynamically typed traces with 'traceM' (which generalise the @base@ library
-- 'Debug.Trace.traceM')
--
-- It also contains information on discovered races.
--
-- See also: 'Control.Monad.IOSim.traceEvents',
-- 'Control.Monad.IOSim.traceResult', 'Control.Monad.IOSim.selectTraceEvents',
-- 'Control.Monad.IOSim.selectTraceEventsDynamic' and
-- 'Control.Monad.IOSim.printTraceEventsSay'.
--
data SimEvent
    -- | Used when using `IOSim`.
  = SimEvent {
      SimEvent -> Time
seTime        :: !Time,
      SimEvent -> IOSimThreadId
seThreadId    :: !IOSimThreadId,
      SimEvent -> Maybe String
seThreadLabel :: !(Maybe ThreadLabel),
      SimEvent -> SimEventType
seType        :: !SimEventType
    }
    -- | Only used for /IOSimPOR/
  | SimPOREvent {
      seTime        :: !Time,
      seThreadId    :: !IOSimThreadId,
      SimEvent -> Int
seStep        :: !Int,
      seThreadLabel :: !(Maybe ThreadLabel),
      seType        :: !SimEventType
    }
    -- | Only used for /IOSimPOR/
  | SimRacesFound [ScheduleControl]
  deriving forall x. Rep SimEvent x -> SimEvent
forall x. SimEvent -> Rep SimEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SimEvent x -> SimEvent
$cfrom :: forall x. SimEvent -> Rep SimEvent x
Generic
  deriving Int -> SimEvent -> String -> String
[SimEvent] -> String -> String
SimEvent -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SimEvent] -> String -> String
$cshowList :: [SimEvent] -> String -> String
show :: SimEvent -> String
$cshow :: SimEvent -> String
showsPrec :: Int -> SimEvent -> String -> String
$cshowsPrec :: Int -> SimEvent -> String -> String
Show via Quiet SimEvent


-- | Pretty print a 'SimEvent'.
--
ppSimEvent :: Int -- ^ width of the time
           -> Int -- ^ width of thread id
           -> Int -- ^ width of thread label
           -> SimEvent
           -> String

ppSimEvent :: Int -> Int -> Int -> SimEvent -> String
ppSimEvent Int
timeWidth Int
tidWidth Int
tLabelWidth SimEvent {seTime :: SimEvent -> Time
seTime = Time DiffTime
time, IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel, SimEventType
seType :: SimEventType
seType :: SimEvent -> SimEventType
seType} =
    forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s"
           Int
timeWidth
           (forall a. Show a => a -> String
show DiffTime
time)
           Int
tidWidth
           (IOSimThreadId -> String
ppIOSimThreadId IOSimThreadId
seThreadId)
           Int
tLabelWidth
           String
threadLabel
           (SimEventType -> String
ppSimEventType SimEventType
seType)
  where
    threadLabel :: String
threadLabel = forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
seThreadLabel

ppSimEvent Int
timeWidth Int
tidWidth Int
tLableWidth SimPOREvent {seTime :: SimEvent -> Time
seTime = Time DiffTime
time, IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId, Int
seStep :: Int
seStep :: SimEvent -> Int
seStep, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel, SimEventType
seType :: SimEventType
seType :: SimEvent -> SimEventType
seType} =
    forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s"
           Int
timeWidth
           (forall a. Show a => a -> String
show DiffTime
time)
           Int
tidWidth
           ((IOSimThreadId, Int) -> String
ppStepId (IOSimThreadId
seThreadId, Int
seStep))
           Int
tLableWidth
           String
threadLabel
           (SimEventType -> String
ppSimEventType SimEventType
seType)
  where
    threadLabel :: String
threadLabel = forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
seThreadLabel

ppSimEvent Int
_ Int
_ Int
_ (SimRacesFound [ScheduleControl]
controls) =
    String
"RacesFound "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show [ScheduleControl]
controls


-- | A result type of a simulation.
data SimResult a
    = MainReturn    !Time !(Labelled IOSimThreadId) a ![Labelled IOSimThreadId]
    -- ^ Return value of the main thread.
    | MainException !Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId]
    -- ^ Exception thrown by the main thread.
    | Deadlock      !Time               ![Labelled IOSimThreadId]
    -- ^ Deadlock discovered in the simulation.  Deadlocks are discovered if
    -- simply the simulation cannot do any progress in a given time slot and
    -- there's no event which would advance the time.
    | Loop
    -- ^ Only returned by /IOSimPOR/ when a step execution took longer than
    -- 'explorationStepTimelimit` was exceeded.
    | InternalError String
    deriving (Int -> SimResult a -> String -> String
forall a. Show a => Int -> SimResult a -> String -> String
forall a. Show a => [SimResult a] -> String -> String
forall a. Show a => SimResult a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SimResult a] -> String -> String
$cshowList :: forall a. Show a => [SimResult a] -> String -> String
show :: SimResult a -> String
$cshow :: forall a. Show a => SimResult a -> String
showsPrec :: Int -> SimResult a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> SimResult a -> String -> String
Show, forall a b. a -> SimResult b -> SimResult a
forall a b. (a -> b) -> SimResult a -> SimResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> SimResult b -> SimResult a
$c<$ :: forall a b. a -> SimResult b -> SimResult a
fmap :: forall a b. (a -> b) -> SimResult a -> SimResult b
$cfmap :: forall a b. (a -> b) -> SimResult a -> SimResult b
Functor)

ppSimResult :: Show a
            => Int
            -> Int
            -> Int
            -> SimResult a
            -> String
ppSimResult :: forall a. Show a => Int -> Int -> Int -> SimResult a -> String
ppSimResult Int
timeWidth Int
tidWidth Int
thLabelWidth SimResult a
r = case SimResult a
r of
    MainReturn (Time DiffTime
time) Labelled IOSimThreadId
tid a
a [Labelled IOSimThreadId]
tids ->
      forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s %s"
             Int
timeWidth
             (forall a. Show a => a -> String
show DiffTime
time)
             Int
tidWidth
             (IOSimThreadId -> String
ppIOSimThreadId (forall a. Labelled a -> a
l_labelled Labelled IOSimThreadId
tid))
             Int
thLabelWidth
             (forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a. Labelled a -> Maybe String
l_label Labelled IOSimThreadId
tid)
             (String
"MainReturn " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a)
             (String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a. (a -> String) -> Labelled a -> String
ppLabelled IOSimThreadId -> String
ppIOSimThreadId forall a b. (a -> b) -> [a] -> [b]
`map` [Labelled IOSimThreadId]
tids) forall a. [a] -> [a] -> [a]
++ String
"]")
    MainException (Time DiffTime
time) Labelled IOSimThreadId
tid SomeException
e [Labelled IOSimThreadId]
tids ->
      forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s %s"
             Int
timeWidth
             (forall a. Show a => a -> String
show DiffTime
time)
             Int
tidWidth
             (IOSimThreadId -> String
ppIOSimThreadId (forall a. Labelled a -> a
l_labelled Labelled IOSimThreadId
tid))
             Int
thLabelWidth
             (forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a. Labelled a -> Maybe String
l_label Labelled IOSimThreadId
tid)
             (String
"MainException " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e)
             (String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a. (a -> String) -> Labelled a -> String
ppLabelled IOSimThreadId -> String
ppIOSimThreadId forall a b. (a -> b) -> [a] -> [b]
`map` [Labelled IOSimThreadId]
tids) forall a. [a] -> [a] -> [a]
++ String
"]")
    Deadlock (Time DiffTime
time) [Labelled IOSimThreadId]
tids ->
      forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s %s"
             Int
timeWidth
             (forall a. Show a => a -> String
show DiffTime
time)
             Int
tidWidth
             String
""
             Int
thLabelWidth
             String
"" 
             String
"Deadlock"
             (String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a. (a -> String) -> Labelled a -> String
ppLabelled IOSimThreadId -> String
ppIOSimThreadId forall a b. (a -> b) -> [a] -> [b]
`map` [Labelled IOSimThreadId]
tids) forall a. [a] -> [a] -> [a]
++ String
"]")
    SimResult a
Loop -> String
"<<io-sim-por: step execution exceded explorationStepTimelimit>>"
    InternalError String
e -> String
"<<io-sim internal error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
e forall a. [a] -> [a] -> [a]
++ String
">>"


-- | A type alias for 'IOSim' simulation trace.  It comes with useful pattern
-- synonyms.
--
type SimTrace a = Trace.Trace (SimResult a) SimEvent

-- | Pretty print simulation trace.
--
ppTrace :: Show a => SimTrace a -> String
ppTrace :: forall a. Show a => SimTrace a -> String
ppTrace SimTrace a
tr = forall a b. (a -> String) -> (b -> String) -> Trace a b -> String
Trace.ppTrace
               (forall a. Show a => Int -> Int -> Int -> SimResult a -> String
ppSimResult Int
timeWidth Int
tidWidth Int
labelWidth)
               (Int -> Int -> Int -> SimEvent -> String
ppSimEvent Int
timeWidth Int
tidWidth Int
labelWidth)
               SimTrace a
tr
  where
    (Max Int
timeWidth, Max Int
tidWidth, Max Int
labelWidth) =
        forall (t :: * -> * -> *) a. (Bifoldable t, Ord a) => t a a -> a
bimaximum
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. a -> b -> a
const (forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0))
              (\SimEvent
a -> case SimEvent
a of
                SimEvent {seTime :: SimEvent -> Time
seTime = Time DiffTime
time, IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show DiffTime
time))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimPOREvent {seTime :: SimEvent -> Time
seTime = Time DiffTime
time, IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show DiffTime
time))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimRacesFound {} ->
                  (forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0)
              )
      forall a b. (a -> b) -> a -> b
$ SimTrace a
tr


-- | Like 'ppTrace' but does not show the result value.
--
ppTrace_ :: SimTrace a -> String
ppTrace_ :: forall a. SimTrace a -> String
ppTrace_ SimTrace a
tr = forall a b. (a -> String) -> (b -> String) -> Trace a b -> String
Trace.ppTrace
                (forall a b. a -> b -> a
const String
"")
                (Int -> Int -> Int -> SimEvent -> String
ppSimEvent Int
timeWidth Int
tidWidth Int
labelWidth)
                SimTrace a
tr
  where
    (Max Int
timeWidth, Max Int
tidWidth, Max Int
labelWidth) =
        forall (t :: * -> * -> *) a. (Bifoldable t, Ord a) => t a a -> a
bimaximum
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. a -> b -> a
const (forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0))
              (\SimEvent
a -> case SimEvent
a of
                SimEvent {Time
seTime :: Time
seTime :: SimEvent -> Time
seTime, IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show Time
seTime))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimPOREvent {Time
seTime :: Time
seTime :: SimEvent -> Time
seTime, IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show Time
seTime))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , forall a. a -> Max a
Max (forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimRacesFound {} ->
                  (forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0, forall a. a -> Max a
Max Int
0)
              )
      forall a b. (a -> b) -> a -> b
$ SimTrace a
tr



-- | Trace each event using 'Debug.trace'; this is useful when a trace ends with
-- a pure error, e.g. an assertion.
--
ppDebug :: SimTrace a -> x -> x
ppDebug :: forall a x. SimTrace a -> x -> x
ppDebug = forall a. Endo a -> a -> a
appEndo
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> a -> a
Debug.trace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Trace a b -> [b]
Trace.toList


pattern SimTrace :: Time -> IOSimThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a
                 -> SimTrace a
pattern $bSimTrace :: forall a.
Time
-> IOSimThreadId
-> Maybe String
-> SimEventType
-> SimTrace a
-> SimTrace a
$mSimTrace :: forall {r} {a}.
SimTrace a
-> (Time
    -> IOSimThreadId
    -> Maybe String
    -> SimEventType
    -> SimTrace a
    -> r)
-> ((# #) -> r)
-> r
SimTrace time threadId threadLabel traceEvent trace =
    Trace.Cons (SimEvent time threadId threadLabel traceEvent)
               trace

pattern SimPORTrace :: Time -> IOSimThreadId -> Int -> Maybe ThreadLabel -> SimEventType -> SimTrace a
                    -> SimTrace a
pattern $bSimPORTrace :: forall a.
Time
-> IOSimThreadId
-> Int
-> Maybe String
-> SimEventType
-> SimTrace a
-> SimTrace a
$mSimPORTrace :: forall {r} {a}.
SimTrace a
-> (Time
    -> IOSimThreadId
    -> Int
    -> Maybe String
    -> SimEventType
    -> SimTrace a
    -> r)
-> ((# #) -> r)
-> r
SimPORTrace time threadId step threadLabel traceEvent trace =
    Trace.Cons (SimPOREvent time threadId step threadLabel traceEvent)
               trace

pattern TraceRacesFound :: [ScheduleControl] -> SimTrace a
                        -> SimTrace a
pattern $bTraceRacesFound :: forall a. [ScheduleControl] -> SimTrace a -> SimTrace a
$mTraceRacesFound :: forall {r} {a}.
SimTrace a
-> ([ScheduleControl] -> SimTrace a -> r) -> ((# #) -> r) -> r
TraceRacesFound controls trace =
    Trace.Cons (SimRacesFound controls)
               trace

pattern TraceMainReturn :: Time -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId]
                        -> SimTrace a
pattern $bTraceMainReturn :: forall a.
Time
-> Labelled IOSimThreadId
-> a
-> [Labelled IOSimThreadId]
-> SimTrace a
$mTraceMainReturn :: forall {r} {a}.
SimTrace a
-> (Time
    -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId] -> r)
-> ((# #) -> r)
-> r
TraceMainReturn time tid a threads = Trace.Nil (MainReturn time tid a threads)

pattern TraceMainException :: Time -> Labelled IOSimThreadId -> SomeException -> [Labelled IOSimThreadId]
                           -> SimTrace a
pattern $bTraceMainException :: forall a.
Time
-> Labelled IOSimThreadId
-> SomeException
-> [Labelled IOSimThreadId]
-> SimTrace a
$mTraceMainException :: forall {r} {a}.
SimTrace a
-> (Time
    -> Labelled IOSimThreadId
    -> SomeException
    -> [Labelled IOSimThreadId]
    -> r)
-> ((# #) -> r)
-> r
TraceMainException time tid err threads = Trace.Nil (MainException time tid err threads)

pattern TraceDeadlock :: Time -> [Labelled IOSimThreadId]
                      -> SimTrace a
pattern $bTraceDeadlock :: forall a. Time -> [Labelled IOSimThreadId] -> SimTrace a
$mTraceDeadlock :: forall {r} {a}.
SimTrace a
-> (Time -> [Labelled IOSimThreadId] -> r) -> ((# #) -> r) -> r
TraceDeadlock time threads = Trace.Nil (Deadlock time threads)

pattern TraceLoop :: SimTrace a
pattern $bTraceLoop :: forall a. SimTrace a
$mTraceLoop :: forall {r} {a}. SimTrace a -> ((# #) -> r) -> ((# #) -> r) -> r
TraceLoop = Trace.Nil Loop

pattern TraceInternalError :: String -> SimTrace a
pattern $bTraceInternalError :: forall a. String -> SimTrace a
$mTraceInternalError :: forall {r} {a}. SimTrace a -> (String -> r) -> ((# #) -> r) -> r
TraceInternalError msg = Trace.Nil (InternalError msg)

{-# COMPLETE SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop, TraceInternalError #-}


-- | Events recorded by the simulation.
--
data SimEventType
  = EventSay  String
  -- ^ hold value of `say`
  | EventLog  Dynamic
  -- ^ hold a dynamic value of `Control.Monad.IOSim.traceM`
  | EventMask MaskingState
  -- ^ masking state changed

  | EventThrow          SomeException
  -- ^ throw exception
  | EventThrowTo        SomeException IOSimThreadId
  -- ^ throw asynchronous exception (`throwTo`)
  | EventThrowToBlocked
  -- ^ the thread which executed `throwTo` is blocked
  | EventThrowToWakeup
  -- ^ the thread which executed `throwTo` is woken up
  | EventThrowToUnmasked (Labelled IOSimThreadId)
  -- ^ a target thread of `throwTo` unmasked its exceptions, this is paired
  -- with `EventThrowToWakeup` for threads which were blocked on `throwTo`

  | EventThreadForked    IOSimThreadId
  -- ^ forked a thread
  | EventThreadFinished
  -- ^ thread terminated normally
  | EventThreadUnhandled SomeException
  -- ^ thread terminated by an unhandled exception

  --
  -- STM events
  --

  -- | committed STM transaction
  | EventTxCommitted   [Labelled TVarId] -- ^ stm tx wrote to these
                       [Labelled TVarId] -- ^ and created these
                       (Maybe Effect)    -- ^ effect performed (only for `IOSimPOR`)
  -- | aborted an STM transaction (by an exception)
  --
  -- For /IOSimPOR/ it also holds performed effect.
  | EventTxAborted     (Maybe Effect)
  -- | STM transaction blocked (due to `retry`)
  | EventTxBlocked     [Labelled TVarId] -- stm tx blocked reading these
                       (Maybe Effect)    -- ^ effect performed (only for `IOSimPOR`)
  | EventTxWakeup      [Labelled TVarId] -- ^ changed vars causing retry

  | EventUnblocked     [IOSimThreadId]
  -- ^ unblocked threads by a committed STM transaction

  --
  -- Timeouts, Timers & Delays
  --

  | EventThreadDelay        TimeoutId Time
  -- ^ thread delayed
  | EventThreadDelayFired   TimeoutId
  -- ^ thread woken up after a delay

  | EventTimeoutCreated        TimeoutId IOSimThreadId Time
  -- ^ new timeout created (via `timeout`)
  | EventTimeoutFired          TimeoutId
  -- ^ timeout fired

  | EventRegisterDelayCreated TimeoutId TVarId Time
  -- ^ registered delay (via `registerDelay`)
  | EventRegisterDelayFired TimeoutId
  -- ^ registered delay fired

  | EventTimerCreated         TimeoutId TVarId Time
  -- ^ a new 'Timeout' created (via `newTimeout`)
  | EventTimerUpdated         TimeoutId        Time
  -- ^ a 'Timeout' was updated (via `updateTimeout`)
  | EventTimerCancelled       TimeoutId
  -- ^ a 'Timeout' was cancelled (via `cancelTimeout`)
  | EventTimerFired           TimeoutId
  -- ^ a 'Timeout` fired

  --
  -- threadStatus
  --

  -- | event traced when `threadStatus` is executed
  | EventThreadStatus  IOSimThreadId -- ^ current thread
                       IOSimThreadId -- ^ queried thread

  --
  -- /IOSimPOR/ events
  --

  | EventSimStart      ScheduleControl
  -- ^ /IOSimPOR/ event: new execution started exploring the given schedule.
  | EventThreadSleep
  -- ^ /IOSimPOR/ event: the labelling thread was runnable, but its execution
  -- was delayed, until 'EventThreadWake'.
  --
  -- Event inserted to mark a difference between a failed trace and a similar
  -- passing trace.
  | EventThreadWake
  -- ^ /IOSimPOR/ event: marks when the thread was rescheduled by /IOSimPOR/
  | EventDeschedule    Deschedule
  -- ^ /IOSim/ and /IOSimPOR/ event: a thread was descheduled
  | EventFollowControl        ScheduleControl
  -- ^ /IOSimPOR/ event: following given schedule
  | EventAwaitControl  StepId ScheduleControl
  -- ^ /IOSimPOR/ event: thread delayed to follow the given schedule
  | EventPerformAction StepId
  -- ^ /IOSimPOR/ event: perform action of the given step
  | EventReschedule           ScheduleControl

  | EventEffect VectorClock Effect
  -- ^ /IOSimPOR/ event: executed effect; Useful for debugging IOSimPOR or
  -- showing compact information about thread execution.
  | EventRaces Races
  -- ^ /IOSimPOR/ event: races.  Races are updated while we execute
  -- a simulation.  Useful for debugging IOSimPOR.
  deriving Int -> SimEventType -> String -> String
[SimEventType] -> String -> String
SimEventType -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SimEventType] -> String -> String
$cshowList :: [SimEventType] -> String -> String
show :: SimEventType -> String
$cshow :: SimEventType -> String
showsPrec :: Int -> SimEventType -> String -> String
$cshowsPrec :: Int -> SimEventType -> String -> String
Show

ppSimEventType :: SimEventType -> String
ppSimEventType :: SimEventType -> String
ppSimEventType = \case
  EventSay String
a -> String
"Say " forall a. [a] -> [a] -> [a]
++ String
a
  EventLog Dynamic
a -> String
"Dynamic " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Dynamic
a
  EventMask MaskingState
a -> String
"Mask " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MaskingState
a
  EventThrow SomeException
a -> String
"Throw " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
a
  EventThrowTo SomeException
err IOSimThreadId
tid ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"ThrowTo (",
              forall a. Show a => a -> String
show SomeException
err, String
") ",
              IOSimThreadId -> String
ppIOSimThreadId IOSimThreadId
tid ]
  SimEventType
EventThrowToBlocked -> String
"ThrowToBlocked"
  SimEventType
EventThrowToWakeup -> String
"ThrowToWakeup"
  EventThrowToUnmasked Labelled IOSimThreadId
a ->
    String
"ThrowToUnmasked " forall a. [a] -> [a] -> [a]
++ forall a. (a -> String) -> Labelled a -> String
ppLabelled IOSimThreadId -> String
ppIOSimThreadId Labelled IOSimThreadId
a
  EventThreadForked IOSimThreadId
a ->
    String
"ThreadForked " forall a. [a] -> [a] -> [a]
++ IOSimThreadId -> String
ppIOSimThreadId IOSimThreadId
a
  SimEventType
EventThreadFinished -> String
"ThreadFinished"
  EventThreadUnhandled SomeException
a ->
    String
"ThreadUnhandled " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
a
  EventTxCommitted [Labelled TVarId]
written [Labelled TVarId]
created Maybe Effect
mbEff ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TxCommitted ",
             forall a. (a -> String) -> [a] -> String
ppList (forall a. (a -> String) -> Labelled a -> String
ppLabelled forall a. Show a => a -> String
show) [Labelled TVarId]
written, String
" ",
             forall a. (a -> String) -> [a] -> String
ppList (forall a. (a -> String) -> Labelled a -> String
ppLabelled forall a. Show a => a -> String
show) [Labelled TVarId]
created,
             forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char
' ' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> String
ppEffect) Maybe Effect
mbEff ]

  EventTxAborted Maybe Effect
mbEff ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TxAborted",
             forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char
' ' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> String
ppEffect) Maybe Effect
mbEff ]
  EventTxBlocked [Labelled TVarId]
blocked Maybe Effect
mbEff ->
   forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TxBlocked ",
             forall a. (a -> String) -> [a] -> String
ppList (forall a. (a -> String) -> Labelled a -> String
ppLabelled forall a. Show a => a -> String
show) [Labelled TVarId]
blocked,
             forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char
' ' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> String
ppEffect) Maybe Effect
mbEff ]
  EventTxWakeup [Labelled TVarId]
changed ->
    String
"TxWakeup " forall a. [a] -> [a] -> [a]
++ forall a. (a -> String) -> [a] -> String
ppList (forall a. (a -> String) -> Labelled a -> String
ppLabelled forall a. Show a => a -> String
show) [Labelled TVarId]
changed
  EventUnblocked [IOSimThreadId]
unblocked ->
    String
"Unblocked " forall a. [a] -> [a] -> [a]
++ forall a. (a -> String) -> [a] -> String
ppList IOSimThreadId -> String
ppIOSimThreadId [IOSimThreadId]
unblocked
  EventThreadDelay TimeoutId
tid Time
t ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"ThreadDelay ",
             forall a. Show a => a -> String
show TimeoutId
tid, String
" ",
             forall a. Show a => a -> String
show Time
t ]
  EventThreadDelayFired  TimeoutId
tid -> String
"ThreadDelayFired " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TimeoutId
tid
  EventTimeoutCreated TimeoutId
timer IOSimThreadId
tid Time
t ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TimeoutCreated ",
             forall a. Show a => a -> String
show TimeoutId
timer, String
" ",
             IOSimThreadId -> String
ppIOSimThreadId IOSimThreadId
tid, String
" ",
             forall a. Show a => a -> String
show Time
t ]
  EventTimeoutFired TimeoutId
timer ->
    String
"TimeoutFired " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TimeoutId
timer
  EventRegisterDelayCreated TimeoutId
timer TVarId
tvarId Time
t ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"RegisterDelayCreated ",
             forall a. Show a => a -> String
show TimeoutId
timer, String
" ",
             forall a. Show a => a -> String
show TVarId
tvarId, String
" ",
             forall a. Show a => a -> String
show Time
t ]
  EventRegisterDelayFired TimeoutId
timer -> String
"RegisterDelayFired " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TimeoutId
timer
  EventTimerCreated TimeoutId
timer TVarId
tvarId Time
t ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TimerCreated ",
              forall a. Show a => a -> String
show TimeoutId
timer, String
" ",
              forall a. Show a => a -> String
show TVarId
tvarId, String
" ",
              forall a. Show a => a -> String
show Time
t ]
  EventTimerUpdated TimeoutId
timer Time
t ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TimerUpdated ",
             forall a. Show a => a -> String
show TimeoutId
timer, String
" ",
             forall a. Show a => a -> String
show Time
t ]
  EventTimerCancelled TimeoutId
timer -> String
"TimerCancelled " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TimeoutId
timer
  EventTimerFired TimeoutId
timer -> String
"TimerFired " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TimeoutId
timer
  EventThreadStatus  IOSimThreadId
tid IOSimThreadId
tid' ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"ThreadStatus ",
             IOSimThreadId -> String
ppIOSimThreadId IOSimThreadId
tid, String
" ",
             IOSimThreadId -> String
ppIOSimThreadId IOSimThreadId
tid' ]
  EventSimStart ScheduleControl
a -> String
"SimStart " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScheduleControl
a
  SimEventType
EventThreadSleep -> String
"ThreadSleep"
  SimEventType
EventThreadWake -> String
"ThreadWake"
  EventDeschedule Deschedule
a -> String
"Deschedule " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Deschedule
a
  EventFollowControl ScheduleControl
a -> String
"FollowControl " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScheduleControl
a
  EventAwaitControl (IOSimThreadId, Int)
s ScheduleControl
a ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"AwaitControl ",
             (IOSimThreadId, Int) -> String
ppStepId (IOSimThreadId, Int)
s, String
" ",
             forall a. Show a => a -> String
show ScheduleControl
a ]
  EventPerformAction (IOSimThreadId, Int)
a -> String
"PerformAction " forall a. [a] -> [a] -> [a]
++ (IOSimThreadId, Int) -> String
ppStepId (IOSimThreadId, Int)
a
  EventReschedule ScheduleControl
a -> String
"Reschedule " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScheduleControl
a
  EventEffect VectorClock
clock Effect
eff ->
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Effect ",
             VectorClock -> String
ppVectorClock VectorClock
clock, String
" ",
             Effect -> String
ppEffect Effect
eff ]
  EventRaces Races
a -> forall a. Show a => a -> String
show Races
a

-- | A labelled value.
--
-- For example 'labelThread' or `labelTVar' will insert a label to `IOSimThreadId`
-- (or `TVarId`).
data Labelled a = Labelled {
    forall a. Labelled a -> a
l_labelled :: !a,
    forall a. Labelled a -> Maybe String
l_label    :: !(Maybe String)
  }
  deriving (Labelled a -> Labelled a -> Bool
forall a. Eq a => Labelled a -> Labelled a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Labelled a -> Labelled a -> Bool
$c/= :: forall a. Eq a => Labelled a -> Labelled a -> Bool
== :: Labelled a -> Labelled a -> Bool
$c== :: forall a. Eq a => Labelled a -> Labelled a -> Bool
Eq, Labelled a -> Labelled a -> Bool
Labelled a -> Labelled a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Labelled a)
forall a. Ord a => Labelled a -> Labelled a -> Bool
forall a. Ord a => Labelled a -> Labelled a -> Ordering
forall a. Ord a => Labelled a -> Labelled a -> Labelled a
min :: Labelled a -> Labelled a -> Labelled a
$cmin :: forall a. Ord a => Labelled a -> Labelled a -> Labelled a
max :: Labelled a -> Labelled a -> Labelled a
$cmax :: forall a. Ord a => Labelled a -> Labelled a -> Labelled a
>= :: Labelled a -> Labelled a -> Bool
$c>= :: forall a. Ord a => Labelled a -> Labelled a -> Bool
> :: Labelled a -> Labelled a -> Bool
$c> :: forall a. Ord a => Labelled a -> Labelled a -> Bool
<= :: Labelled a -> Labelled a -> Bool
$c<= :: forall a. Ord a => Labelled a -> Labelled a -> Bool
< :: Labelled a -> Labelled a -> Bool
$c< :: forall a. Ord a => Labelled a -> Labelled a -> Bool
compare :: Labelled a -> Labelled a -> Ordering
$ccompare :: forall a. Ord a => Labelled a -> Labelled a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Labelled a) x -> Labelled a
forall a x. Labelled a -> Rep (Labelled a) x
$cto :: forall a x. Rep (Labelled a) x -> Labelled a
$cfrom :: forall a x. Labelled a -> Rep (Labelled a) x
Generic)
  deriving Int -> Labelled a -> String -> String
[Labelled a] -> String -> String
Labelled a -> String
forall a. Show a => Int -> Labelled a -> String -> String
forall a. Show a => [Labelled a] -> String -> String
forall a. Show a => Labelled a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Labelled a] -> String -> String
$cshowList :: forall a. Show a => [Labelled a] -> String -> String
show :: Labelled a -> String
$cshow :: forall a. Show a => Labelled a -> String
showsPrec :: Int -> Labelled a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Labelled a -> String -> String
Show via Quiet (Labelled a)

ppLabelled :: (a -> String) -> Labelled a -> String
ppLabelled :: forall a. (a -> String) -> Labelled a -> String
ppLabelled a -> String
pp Labelled { l_labelled :: forall a. Labelled a -> a
l_labelled = a
a, l_label :: forall a. Labelled a -> Maybe String
l_label = Maybe String
Nothing  } = a -> String
pp a
a
ppLabelled a -> String
pp Labelled { l_labelled :: forall a. Labelled a -> a
l_labelled = a
a, l_label :: forall a. Labelled a -> Maybe String
l_label = Just String
lbl } = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Labelled ", a -> String
pp a
a, String
" ", String
lbl]

--
-- Executing STM Transactions
--

-- | Result of an STM computation.
--
data StmTxResult s a =
       -- | A committed transaction reports the vars that were written (in order
       -- of first write) so that the scheduler can unblock other threads that
       -- were blocked in STM transactions that read any of these vars.
       --
       -- It reports the vars that were read, so we can update vector clocks
       -- appropriately.
       --
       -- The third list of vars is ones that were created during this
       -- transaction.  This is useful for an implementation of 'traceTVar'.
       --
       -- It also includes the updated TVarId name supply.
       --
       StmTxCommitted a [SomeTVar s] -- ^ written tvars
                        [SomeTVar s] -- ^ read tvars
                        [SomeTVar s] -- ^ created tvars
                        [Dynamic]
                        [String]
                        TVarId -- updated TVarId name supply

       -- | A blocked transaction reports the vars that were read so that the
       -- scheduler can block the thread on those vars.
       --
     | StmTxBlocked  [SomeTVar s]

       -- | An aborted transaction reports the vars that were read so that the
       -- vector clock can be updated.
       --
     | StmTxAborted  [SomeTVar s] SomeException


-- | A branch indicates that an alternative statement is available in the current
-- context. For example, `OrElse` has two alternative statements, say "left"
-- and "right". While executing the left statement, `OrElseStmA` branch indicates
-- that the right branch is still available, in case the left statement fails.
data BranchStmA s a =
       -- | `OrElse` statement with its 'right' alternative.
       OrElseStmA (StmA s a)
       -- | `CatchStm` statement with the 'catch' handler.
     | CatchStmA (SomeException -> StmA s a)
       -- | Unlike the other two branches, the no-op branch is not an explicit
       -- part of the STM syntax. It simply indicates that there are no
       -- alternative statements left to be executed. For example, when running
       -- right alternative of the `OrElse` statement or when running the catch
       -- handler of a `CatchStm` statement, there are no alternative statements
       -- available. This case is represented by the no-op branch.
     | NoOpStmA

data StmStack s b a where
  -- | Executing in the context of a top level 'atomically'.
  AtomicallyFrame  :: StmStack s a a

  -- | Executing in the context of the /left/ hand side of a branch.
  -- A right branch is represented by a frame containing empty statement.
  BranchFrame      :: !(BranchStmA s a)       -- right alternative, can be empty
                   -> (a -> StmA s b)         -- subsequent continuation
                   -> Map TVarId (SomeTVar s) -- saved written vars set
                   -> [SomeTVar s]            -- saved written vars list
                   -> [SomeTVar s]            -- created vars list
                   -> StmStack s b c
                   -> StmStack s a c

---
--- Exploration options
---

-- | Race exploration options.
--
data ExplorationOptions = ExplorationOptions{
    ExplorationOptions -> Int
explorationScheduleBound :: Int,
    -- ^ This is an upper bound on the number of schedules with race reversals
    -- that will be explored; a bound of zero means that the default schedule
    -- will be explored, but no others. Setting the bound to zero makes
    -- IOSimPOR behave rather like IOSim, in that only one schedule is
    -- explored, but (a) IOSimPOR is considerably slower, because it still
    -- collects information on potential races, and (b) the IOSimPOR schedule
    -- is different (based on priorities, in contrast to IOSim's round-robin),
    -- and plays better with shrinking.
    --
    -- The default value is `100`.
    ExplorationOptions -> Int
explorationBranching     :: Int,
    -- ^ The branching factor. This is the number of alternative schedules that
    -- IOSimPOR tries to run, per race reversal. With the default parameters,
    -- IOSimPOR will try to reverse the first 33 (100 div 3) races discovered
    -- using the default schedule, then (if 33 or more races are discovered),
    -- for each such reversed race, will run the reversal and try to reverse
    -- two more races in the resulting schedule. A high branching factor will
    -- explore more combinations of reversing fewer races, within the overall
    -- schedule bound. A branching factor of one will explore only schedules
    -- resulting from a single race reversal (unless there are fewer races
    -- available to be reversed than the schedule bound).
    --
    -- The default value is `3`.
    ExplorationOptions -> Maybe Int
explorationStepTimelimit :: Maybe Int,
    -- ^ Limit on the computation time allowed per scheduling step, for
    -- catching infinite loops etc.
    --
    -- The default value is `Nothing`.
    ExplorationOptions -> Maybe ScheduleControl
explorationReplay        :: Maybe ScheduleControl,
    -- ^ A schedule to replay.
    --
    -- The default value is `Nothing`.
    ExplorationOptions -> Int
explorationDebugLevel    :: Int
    -- ^ Log detailed trace to stderr containing information on discovered
    -- races.  The trace does not contain the result of the simulation, unless
    -- one will do that explicitly inside the simulation.
    --
    -- level 0: don't show any output,
    -- level 1: show simulation trace with discovered schedules
    -- level 2: show simulation trace with discovered schedules and races
    --
    -- NOTE: discovered schedules & races are not exposed to the user in the
    -- callback of `exploreSimTrace` or in the output of `controlSimTrace`.
  }
  deriving Int -> ExplorationOptions -> String -> String
[ExplorationOptions] -> String -> String
ExplorationOptions -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ExplorationOptions] -> String -> String
$cshowList :: [ExplorationOptions] -> String -> String
show :: ExplorationOptions -> String
$cshow :: ExplorationOptions -> String
showsPrec :: Int -> ExplorationOptions -> String -> String
$cshowsPrec :: Int -> ExplorationOptions -> String -> String
Show

stdExplorationOptions :: ExplorationOptions
stdExplorationOptions :: ExplorationOptions
stdExplorationOptions = ExplorationOptions{
    explorationScheduleBound :: Int
explorationScheduleBound = Int
100,
    explorationBranching :: Int
explorationBranching     = Int
3,
    explorationStepTimelimit :: Maybe Int
explorationStepTimelimit = forall a. Maybe a
Nothing,
    explorationReplay :: Maybe ScheduleControl
explorationReplay        = forall a. Maybe a
Nothing,
    explorationDebugLevel :: Int
explorationDebugLevel    = Int
0
    }

type ExplorationSpec = ExplorationOptions -> ExplorationOptions

withScheduleBound :: Int -> ExplorationSpec
withScheduleBound :: Int -> ExplorationSpec
withScheduleBound Int
n ExplorationOptions
e = ExplorationOptions
e{explorationScheduleBound :: Int
explorationScheduleBound = Int
n}

withBranching :: Int -> ExplorationSpec
withBranching :: Int -> ExplorationSpec
withBranching Int
n ExplorationOptions
e = ExplorationOptions
e{explorationBranching :: Int
explorationBranching = Int
n}

withStepTimelimit :: Int -> ExplorationSpec
withStepTimelimit :: Int -> ExplorationSpec
withStepTimelimit Int
n ExplorationOptions
e = ExplorationOptions
e{explorationStepTimelimit :: Maybe Int
explorationStepTimelimit = forall a. a -> Maybe a
Just Int
n}

withReplay :: ScheduleControl -> ExplorationSpec
withReplay :: ScheduleControl -> ExplorationSpec
withReplay ScheduleControl
r ExplorationOptions
e = ExplorationOptions
e{explorationReplay :: Maybe ScheduleControl
explorationReplay = forall a. a -> Maybe a
Just ScheduleControl
r}