{-# LANGUAGE BangPatterns              #-}
{-# 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 ScopedTypeVariables       #-}
{-# 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 Control.Concurrent.Class.MonadSTM.Strict.TVar qualified as StrictTVar
import Control.Monad.Class.MonadAsync hiding (Async)
import Control.Monad.Class.MonadAsync qualified as MonadAsync
import Control.Monad.Class.MonadEventlog
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..),
           MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..), TArrayDefault,
           TChanDefault, TMVarDefault, TSemDefault, TraceValue, atomically,
           retry)
import Control.Monad.Class.MonadSTM.Internal qualified as MonadSTM
import Control.Monad.Class.MonadTest
import Control.Monad.Class.MonadThrow as MonadThrow hiding (getMaskingState)
import Control.Monad.Class.MonadThrow qualified 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 Control.Monad.Class.MonadTimer.SI qualified as SI
import Control.Monad.Primitive qualified as Prim
import Control.Monad.ST.Lazy
import Control.Monad.ST.Strict qualified as StrictST
import Control.Monad.ST.Unsafe (unsafeSTToIO)

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

import Data.Bifoldable
import Data.Bifunctor (bimap)
import Data.Dynamic (Dynamic, toDyn)
import Data.List.Trace qualified as Trace
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid (Endo (..))
import Data.Semigroup (Max (..))
import Data.STRef.Lazy
import Data.Time.Clock (diffTimeToPicoseconds)
import Data.Typeable
import Data.Word (Word64)
import Debug.Trace qualified 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 Data.List (intercalate)
import GHC.IO (mkUserError)
import System.IO.Error qualified as IO.Error (userError)

{-# 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) = (a -> SimA s a) -> SimA s a
forall r. (a -> SimA s r) -> SimA s r
k a -> SimA s a
forall a s. a -> SimA s a
Return

-- | 'IOSim' has the ability to store 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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> Dynamic -> SimA s r -> SimA s r
forall s b. Dynamic -> SimA s b -> SimA s b
Output (a -> Dynamic
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 r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (() -> StmA s r) -> StmA s r) -> STM s ())
-> (forall r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall a b. (a -> b) -> a -> b
$ ((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r)
-> ((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> Dynamic -> StmA s r -> StmA s r
forall s b. Dynamic -> StmA s b -> StmA s b
OutputStm (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x) (() -> StmA s r
k ())

data Thrower = ThrowSelf | ThrowOther deriving (Eq Thrower
Eq Thrower =>
(Thrower -> Thrower -> Ordering)
-> (Thrower -> Thrower -> Bool)
-> (Thrower -> Thrower -> Bool)
-> (Thrower -> Thrower -> Bool)
-> (Thrower -> Thrower -> Bool)
-> (Thrower -> Thrower -> Thrower)
-> (Thrower -> Thrower -> Thrower)
-> Ord 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
$ccompare :: Thrower -> Thrower -> Ordering
compare :: Thrower -> Thrower -> Ordering
$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
>= :: Thrower -> Thrower -> Bool
$cmax :: Thrower -> Thrower -> Thrower
max :: Thrower -> Thrower -> Thrower
$cmin :: Thrower -> Thrower -> Thrower
min :: Thrower -> Thrower -> Thrower
Ord, Thrower -> Thrower -> Bool
(Thrower -> Thrower -> Bool)
-> (Thrower -> Thrower -> Bool) -> Eq Thrower
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Thrower -> Thrower -> Bool
== :: Thrower -> Thrower -> Bool
$c/= :: Thrower -> Thrower -> Bool
/= :: Thrower -> Thrower -> Bool
Eq, Int -> Thrower -> String -> String
[Thrower] -> String -> String
Thrower -> String
(Int -> Thrower -> String -> String)
-> (Thrower -> String)
-> ([Thrower] -> String -> String)
-> Show Thrower
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Thrower -> String -> String
showsPrec :: Int -> Thrower -> String -> String
$cshow :: Thrower -> String
show :: Thrower -> String
$cshowList :: [Thrower] -> String -> String
showList :: [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 = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) (a -> a -> a) -> STM s a -> STM s (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s a
a STM s (a -> a) -> STM s a -> STM s a
forall a b. STM s (a -> b) -> STM s a -> STM s b
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 = a -> STM s a
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
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) = (a -> StmA s a) -> StmA s a
forall r. (a -> StmA s r) -> StmA s r
k a -> StmA s a
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

-- | `IOSim`'s 'MonadSTM.STM' monad, as 'IOSim' it is parametrised by @s@, e.g.
-- @STMSim s a@ is monadic expression of type @a@.
--
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 r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r)
-> ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
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 (b -> SimA s r) -> (a -> b) -> a -> SimA s r
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
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 r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r)
-> ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k ->
                        IOSim s (a -> b) -> forall r. ((a -> b) -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s (a -> b)
df (\a -> b
f -> IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
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 r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r)
-> ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dm (\a
_ -> IOSim s b -> forall r. (b -> SimA s r) -> SimA s r
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 = a -> IOSim s a
forall a. a -> IOSim s a
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 r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r)
-> ((b -> SimA s r) -> SimA s r) -> (b -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dm (\a
m -> IOSim s b -> forall r. (b -> SimA s r) -> SimA s r
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
(>>) = IOSim s a -> IOSim s b -> IOSim s b
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
(<>) = (a -> a -> a) -> IOSim s a -> IOSim s a -> IOSim s a
forall a b c. (a -> b -> c) -> IOSim s a -> IOSim s b -> IOSim s c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (IOSim s a) where
    mempty :: IOSim s a
mempty = a -> IOSim s a
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
_ -> SomeException -> SimA s r
forall s a. SomeException -> SimA s a
Throw (IOError -> SomeException
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> (a -> IOSim s a) -> (a -> SimA s r) -> SimA s r
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 Alternative (IOSim s) where
    empty :: forall a. IOSim s a
empty = SomeException -> IOSim s a
forall e a. Exception e => e -> IOSim s a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (String -> SomeException
mkUserError String
"mzero")
    <|> :: forall a. IOSim s a -> IOSim s a -> IOSim s a
(<|>) !IOSim s a
a IOSim s a
b = IOSim s a
a IOSim s a -> (IOError -> IOSim s a) -> IOSim s a
forall e a.
Exception e =>
IOSim s a -> (e -> IOSim s a) -> IOSim s a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOError
_ :: IOError) -> IOSim s a
b

instance MonadPlus (IOSim s)

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 r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r)
-> ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> STM s a -> forall r. (a -> StmA s r) -> StmA s r
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 (b -> StmA s r) -> (a -> b) -> a -> StmA s r
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 r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
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 r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r)
-> ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k ->
                        STM s (a -> b) -> forall r. ((a -> b) -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s (a -> b)
df (\a -> b
f -> STM s a -> forall r. (a -> StmA s r) -> StmA s r
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 r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r)
-> ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> STM s a -> forall r. (a -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dm (\a
_ -> STM s b -> forall r. (b -> StmA s r) -> StmA s r
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 = a -> STM s a
forall a. a -> STM s a
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 r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r)
-> ((b -> StmA s r) -> StmA s r) -> (b -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> STM s a -> forall r. (a -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dm (\a
m -> STM s b -> forall r. (b -> StmA s r) -> StmA s r
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
(>>) = STM s a -> STM s b -> STM s b
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 r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> SomeException -> StmA s r
forall s a. SomeException -> StmA s a
ThrowStm (ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> ErrorCall
ErrorCall String
msg))

instance Alternative (STM s) where
    empty :: forall a. STM s a
empty = STM (IOSim s) a
STM s a
forall a. STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a
MonadSTM.retry
    <|> :: forall a. STM s a -> STM s a -> STM s a
(<|>) = STM (IOSim s) a -> STM (IOSim s) a -> STM (IOSim s) a
STM s a -> STM s a -> STM s a
forall a. STM (IOSim s) a -> STM (IOSim s) a -> STM (IOSim 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 r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> (a -> STM s a) -> (a -> StmA s r) -> StmA s r
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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> String -> SimA s r -> SimA s r
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
_ -> SomeException -> SimA s r
forall s a. SomeException -> SimA s a
Throw (e -> SomeException
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> a -> (a -> SimA s r) -> SimA s r
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 = Maybe ThunkInfo -> IO (Maybe ThunkInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ThunkInfo
forall a. Maybe a
Nothing

instance Exceptions.MonadThrow (IOSim s) where
  throwM :: forall e a. (HasCallStack, Exception e) => e -> IOSim s a
throwM = e -> IOSim s a
forall e a. Exception e => e -> IOSim s a
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 r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> SomeException -> StmA s r
forall s a. SomeException -> StmA s a
ThrowStm (e -> SomeException
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
    c -> STM s c
forall a. a -> STM s 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
    a -> STM s a
forall a. a -> STM s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

instance Exceptions.MonadThrow (STM s) where
  throwM :: forall e a. (HasCallStack, Exception e) => e -> STM s a
throwM = e -> STM s a
forall e a. Exception e => e -> STM s a
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 r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> StmA s a
-> (SomeException -> StmA s a) -> (a -> StmA s r) -> StmA s r
forall s a b.
StmA s a
-> (SomeException -> StmA s a) -> (a -> StmA s b) -> StmA s b
CatchStm (STM s a -> StmA s a
forall s a. STM s a -> StmA s a
runSTM STM s a
action) (STM s a -> StmA s a
forall s a. STM s a -> StmA s a
runSTM (STM s a -> StmA s a)
-> (SomeException -> STM s a) -> SomeException -> StmA s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> STM s a) -> SomeException -> STM s a
forall e 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 a.
Exception e =>
(e -> STM s a) -> SomeException -> STM s a
fromHandler e -> STM s a
h SomeException
e = case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Maybe e
Nothing -> SomeException -> STM s a
forall e a. Exception e => e -> STM s a
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 STM s b -> (SomeException -> STM s b) -> STM s b
forall e a. Exception e => STM s a -> (e -> STM s a) -> STM s a
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 (SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)
      SomeException -> STM s b
forall e a. Exception e => e -> STM s a
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 (b -> ExitCase b
forall a. a -> ExitCase a
ExitCaseSuccess b
b)
    (b, c) -> STM s (b, c)
forall a. a -> STM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)

instance Exceptions.MonadCatch (STM s) where
  catch :: forall e a.
(HasCallStack, Exception e) =>
STM s a -> (e -> STM s a) -> STM s a
catch = STM s a -> (e -> STM s a) -> STM s a
forall e a. Exception e => STM s a -> (e -> STM s a) -> STM s a
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> SimA s a -> (e -> SimA s a) -> (a -> SimA s r) -> SimA s r
forall a s a b.
Exception a =>
SimA s a -> (a -> SimA s a) -> (a -> SimA s b) -> SimA s b
Catch (IOSim s a -> SimA s a
forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
action) (IOSim s a -> SimA s a
forall s a. IOSim s a -> SimA s a
runIOSim (IOSim s a -> SimA s a) -> (e -> IOSim s a) -> e -> SimA s a
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.
(HasCallStack, Exception e) =>
IOSim s a -> (e -> IOSim s a) -> IOSim s a
catch = IOSim s a -> (e -> IOSim s a) -> IOSim s a
forall e a.
Exception e =>
IOSim s a -> (e -> IOSim s a) -> IOSim s a
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 <- IOSim s MaskingState
forall s. IOSim s MaskingState
getMaskingStateImpl
      case MaskingState
b of
        MaskingState
Unmasked              -> IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
block (IOSim s b -> IOSim s b) -> IOSim s b -> IOSim s b
forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
unblock
        MaskingState
MaskedInterruptible   -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
block
        MaskingState
MaskedUninterruptible -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
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 <- IOSim s MaskingState
forall s. IOSim s MaskingState
getMaskingStateImpl
      case MaskingState
b of
        MaskingState
Unmasked              -> IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
blockUninterruptible (IOSim s b -> IOSim s b) -> IOSim s b -> IOSim s b
forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
unblock
        MaskingState
MaskedInterruptible   -> IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
blockUninterruptible (IOSim s b -> IOSim s b) -> IOSim s b -> IOSim s b
forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
block
        MaskingState
MaskedUninterruptible -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
blockUninterruptible

instance MonadMaskingState (IOSim s) where
  getMaskingState :: IOSim s MaskingState
getMaskingState = IOSim s MaskingState
forall s. IOSim s MaskingState
getMaskingStateImpl
  interruptible :: forall a. IOSim s a -> IOSim s a
interruptible IOSim s a
action = do
      MaskingState
b <- IOSim s MaskingState
forall s. IOSim s MaskingState
getMaskingStateImpl
      case MaskingState
b of
        MaskingState
Unmasked              -> IOSim s a
action
        MaskingState
MaskedInterruptible   -> IOSim s a -> IOSim s a
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.
HasCallStack =>
((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) -> IOSim s b
forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.mask
  uninterruptibleMask :: forall b.
HasCallStack =>
((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) -> IOSim s b
forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.uninterruptibleMask

  generalBracket :: forall a b c.
HasCallStack =>
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 a. IOSim s a -> IOSim s a) -> IOSim s (b, c))
-> IOSim s (b, c)
forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IOSim s a -> IOSim s a) -> IOSim s (b, c))
 -> IOSim s (b, c))
-> ((forall a. IOSim s a -> IOSim s a) -> IOSim s (b, c))
-> IOSim s (b, c)
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 <- IOSim s b -> IOSim s b
forall a. IOSim s a -> IOSim s a
unmasked (a -> IOSim s b
use a
resource) IOSim s b -> (SomeException -> IOSim s b) -> IOSim s b
forall e a.
Exception e =>
IOSim s a -> (e -> IOSim s a) -> IOSim s a
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 (SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
Exceptions.ExitCaseException SomeException
e)
        SomeException -> IOSim s b
forall e a. Exception e => e -> IOSim s a
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 (b -> ExitCase b
forall a. a -> ExitCase a
Exceptions.ExitCaseSuccess b
b)
      (b, c) -> IOSim s (b, c)
forall a. a -> IOSim s a
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 <- ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (ST s a -> IO a)
-> (StrictTVar (IOSim s) a -> ST s a)
-> StrictTVar (IOSim s) a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s a -> ST s a
forall s a. ST s a -> ST s a
lazyToStrictST (ST s a -> ST s a)
-> (StrictTVar (IOSim s) a -> ST s a)
-> StrictTVar (IOSim s) a
-> ST s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar s a -> ST s a
forall s a. TVar s a -> ST s a
execReadTVar (TVar s a -> ST s a)
-> (StrictTVar (IOSim s) a -> TVar s a)
-> StrictTVar (IOSim s) a
-> ST s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar (IOSim s) a -> LazyTVar (IOSim s) a
StrictTVar (IOSim s) a -> TVar s a
forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
StrictTVar.toLazyTVar
                        (StrictTVar (IOSim s) a -> IO a) -> StrictTVar (IOSim s) a -> IO a
forall a b. (a -> b) -> a -> b
$ StrictTVar (IOSim s) a
tvar
      Context -> a -> IO (Maybe ThunkInfo)
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 :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent} = STRef s a -> ST s a
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 r. (MaskingState -> SimA s r) -> SimA s r)
-> IOSim s MaskingState
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim  (MaskingState -> SimA s r) -> SimA s r
forall r. (MaskingState -> SimA s r) -> SimA s r
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (MaskingState -> IOSim s a -> (a -> SimA s r) -> SimA s r
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (MaskingState -> IOSim s a -> (a -> SimA s r) -> SimA s r
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (MaskingState -> IOSim s a -> (a -> SimA s r) -> SimA s r
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 r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (ThreadId (IOSim s))
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
 -> IOSim s (ThreadId (IOSim s)))
-> (forall r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ ((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> (ThreadId (IOSim s) -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
 -> (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> ((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> (ThreadId (IOSim s) -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \ThreadId (IOSim s) -> SimA s r
k -> (IOSimThreadId -> SimA s r) -> SimA s r
forall s b. (IOSimThreadId -> SimA s b) -> SimA s b
GetThreadId ThreadId (IOSim s) -> SimA s r
IOSimThreadId -> SimA s r
k
  labelThread :: ThreadId (IOSim s) -> String -> IOSim s ()
labelThread ThreadId (IOSim s)
t String
l  = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> IOSimThreadId -> String -> SimA s r -> SimA s r
forall s b. IOSimThreadId -> String -> SimA s b -> SimA s b
LabelThread ThreadId (IOSim s)
IOSimThreadId
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 r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (ThreadId (IOSim s))
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
 -> IOSim s (ThreadId (IOSim s)))
-> (forall r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ ((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> (ThreadId (IOSim s) -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
 -> (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> ((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> (ThreadId (IOSim s) -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \ThreadId (IOSim s) -> SimA s r
k -> IOSim s () -> (IOSimThreadId -> SimA s r) -> SimA s r
forall s b. IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
Fork IOSim s ()
task ThreadId (IOSim s) -> SimA s r
IOSimThreadId -> SimA s r
k
  forkOn :: Int -> IOSim s () -> IOSim s (ThreadId (IOSim s))
forkOn Int
_ IOSim s ()
task      = (forall r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (ThreadId (IOSim s))
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
 -> IOSim s (ThreadId (IOSim s)))
-> (forall r. (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ ((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> (ThreadId (IOSim s) -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
 -> (ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> ((ThreadId (IOSim s) -> SimA s r) -> SimA s r)
-> (ThreadId (IOSim s) -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \ThreadId (IOSim s) -> SimA s r
k -> IOSim s () -> (IOSimThreadId -> SimA s r) -> SimA s r
forall s b. IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
Fork IOSim s ()
task ThreadId (IOSim s) -> SimA s r
IOSimThreadId -> 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 = IOSim s () -> IOSim s (ThreadId (IOSim s))
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO ((forall a. IOSim s a -> IOSim s a) -> IOSim s ()
f IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
unblock)
  forkFinally :: forall a.
IOSim s a
-> (Either SomeException a -> IOSim s ())
-> IOSim s (ThreadId (IOSim s))
forkFinally IOSim s a
task Either SomeException a -> IOSim s ()
k = ((forall a. IOSim s a -> IOSim s a)
 -> IOSim s (ThreadId (IOSim s)))
-> IOSim s (ThreadId (IOSim s))
forall b.
((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IOSim s a -> IOSim s a)
  -> IOSim s (ThreadId (IOSim s)))
 -> IOSim s (ThreadId (IOSim s)))
-> ((forall a. IOSim s a -> IOSim s a)
    -> IOSim s (ThreadId (IOSim s)))
-> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ \forall a. IOSim s a -> IOSim s a
restore ->
                       IOSim s () -> IOSim s (ThreadId (IOSim s))
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (IOSim s () -> IOSim s (ThreadId (IOSim s)))
-> IOSim s () -> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ IOSim s a -> IOSim s (Either SomeException a)
forall e a. Exception e => IOSim s a -> IOSim s (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IOSim s a -> IOSim s a
forall a. IOSim s a -> IOSim s a
restore IOSim s a
task) IOSim s (Either SomeException a)
-> (Either SomeException a -> IOSim s ()) -> IOSim s ()
forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException a -> IOSim s ()
k
  throwTo :: forall e. Exception e => ThreadId (IOSim s) -> e -> IOSim s ()
throwTo ThreadId (IOSim s)
tid e
e      = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> SomeException -> IOSimThreadId -> SimA s r -> SimA s r
forall s a. SomeException -> IOSimThreadId -> SimA s a -> SimA s a
ThrowTo (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e) ThreadId (IOSim s)
IOSimThreadId
tid (() -> SimA s r
k ())
  yield :: IOSim s ()
yield              = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> SimA s r -> SimA s r
forall s a. SimA s a -> SimA s a
YieldSim (() -> SimA s r
k ())

instance MonadTest (IOSim s) where
  exploreRaces :: IOSim s ()
exploreRaces       = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> SimA s r -> SimA s r
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 r. (() -> StmA s r) -> StmA s r) -> STMSim s ()
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (() -> StmA s r) -> StmA s r) -> STMSim s ())
-> (forall r. (() -> StmA s r) -> StmA s r) -> STMSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r)
-> ((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> String -> StmA s r -> StmA s r
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 r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (() -> StmA s r) -> StmA s r) -> STM s ())
-> (forall r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> String -> TVar s a -> StmA s r -> StmA s r
forall s a b. String -> TVar s a -> StmA s b -> StmA s b
LabelTVar String
label TVar (IOSim s) a
TVar 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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k ->
                                   ST s () -> (() -> SimA s r) -> SimA s r
forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ( ST s () -> ST s ()
forall s a. ST s a -> ST s a
lazyToStrictST (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                                            STRef s (Maybe String) -> Maybe String -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (TVar s a -> STRef s (Maybe String)
forall s a. TVar s a -> STRef s (Maybe String)
tvarLabel TVar (IOSim s) a
TVar s a
tvar) (Maybe String -> ST s ()) -> Maybe String -> ST s ()
forall a b. (a -> b) -> a -> b
$! String -> Maybe String
forall a. a -> Maybe a
Just String
label
                                          ) () -> SimA s r
k
  labelTQueue :: forall a. TQueue (IOSim s) a -> String -> STM (IOSim s) ()
labelTQueue  = TQueue (IOSim s) a -> String -> STM (IOSim s) ()
TQueueDefault (IOSim s) a -> String -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TQueueDefault m a -> String -> STM m ()
labelTQueueDefault
  labelTBQueue :: forall a. TBQueue (IOSim s) a -> String -> STM (IOSim s) ()
labelTBQueue = TBQueue (IOSim s) a -> String -> STM (IOSim s) ()
TBQueueDefault (IOSim s) a -> String -> STM (IOSim s) ()
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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> STM s a -> (a -> SimA s r) -> SimA s r
forall s a b. STM s a -> (a -> SimA s b) -> SimA s b
Atomically STM (IOSim s) a
STM s a
action a -> SimA s r
k

  newTVar :: forall a. a -> STM (IOSim s) (TVar (IOSim s) a)
newTVar         a
x = (forall r. (TVar s a -> StmA s r) -> StmA s r) -> STM s (TVar s a)
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (TVar s a -> StmA s r) -> StmA s r)
 -> STM s (TVar s a))
-> (forall r. (TVar s a -> StmA s r) -> StmA s r)
-> STM s (TVar s a)
forall a b. (a -> b) -> a -> b
$ ((TVar s a -> StmA s r) -> StmA s r)
-> (TVar s a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((TVar s a -> StmA s r) -> StmA s r)
 -> (TVar s a -> StmA s r) -> StmA s r)
-> ((TVar s a -> StmA s r) -> StmA s r)
-> (TVar s a -> StmA s r)
-> StmA s r
forall a b. (a -> b) -> a -> b
$ \TVar s a -> StmA s r
k -> Maybe String -> a -> (TVar s a -> StmA s r) -> StmA s r
forall a s b.
Maybe String -> a -> (TVar s a -> StmA s b) -> StmA s b
NewTVar Maybe String
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 r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> TVar s a -> (a -> StmA s r) -> StmA s r
forall s a b. TVar s a -> (a -> StmA s b) -> StmA s b
ReadTVar TVar (IOSim s) a
TVar 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 r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (() -> StmA s r) -> StmA s r) -> STM s ())
-> (forall r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall a b. (a -> b) -> a -> b
$ ((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r)
-> ((() -> StmA s r) -> StmA s r) -> (() -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> TVar s a -> a -> StmA s r -> StmA s r
forall s a b. TVar s a -> a -> StmA s b -> StmA s b
WriteTVar TVar (IOSim s) a
TVar s a
tvar a
x (() -> StmA s r
k ())
  retry :: forall a. STM (IOSim s) a
retry             = (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> 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 r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r)
-> ((a -> StmA s r) -> StmA s r) -> (a -> StmA s r) -> StmA s r
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> StmA s a -> StmA s a -> (a -> StmA s r) -> StmA s r
forall s a b. StmA s a -> StmA s a -> (a -> StmA s b) -> StmA s b
OrElse (STM s a -> StmA s a
forall s a. STM s a -> StmA s a
runSTM STM (IOSim s) a
STM s a
a) (STM s a -> StmA s a
forall s a. STM s a -> StmA s a
runSTM STM (IOSim s) a
STM s a
b) a -> StmA s r
k

  newTMVar :: forall a. a -> STM (IOSim s) (TMVar (IOSim s) a)
newTMVar          = a -> STM (IOSim s) (TMVarDefault (IOSim s) a)
a -> STM (IOSim s) (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TMVarDefault m a)
MonadSTM.newTMVarDefault
  newEmptyTMVar :: forall a. STM (IOSim s) (TMVar (IOSim s) a)
newEmptyTMVar     = STM (IOSim s) (TMVarDefault (IOSim s) a)
STM (IOSim s) (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => STM m (TMVarDefault m a)
MonadSTM.newEmptyTMVarDefault
  takeTMVar :: forall a. TMVar (IOSim s) a -> STM (IOSim s) a
takeTMVar         = TMVarDefault (IOSim s) a -> STM (IOSim s) a
TMVar (IOSim s) a -> STM (IOSim s) a
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      = TMVarDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
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          = TMVarDefault (IOSim s) a -> a -> STM (IOSim s) ()
TMVar (IOSim s) a -> a -> STM (IOSim s) ()
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       = TMVarDefault (IOSim s) a -> a -> STM (IOSim s) Bool
TMVar (IOSim s) a -> a -> STM (IOSim s) Bool
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         = TMVarDefault (IOSim s) a -> STM (IOSim s) a
TMVar (IOSim s) a -> STM (IOSim s) a
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      = TMVarDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
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         = TMVarDefault (IOSim s) a -> a -> STM (IOSim s) a
TMVar (IOSim s) a -> a -> STM (IOSim s) a
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      = TMVarDefault (IOSim s) a -> STM (IOSim s) Bool
TMVar (IOSim s) a -> STM (IOSim s) Bool
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m Bool
MonadSTM.isEmptyTMVarDefault

  newTQueue :: forall a. STM (IOSim s) (TQueue (IOSim s) a)
newTQueue         = STM (IOSim s) (TQueue (IOSim s) a)
STM (IOSim s) (TQueueDefault (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueueDefault m a)
newTQueueDefault
  readTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) a
readTQueue        = TQueue (IOSim s) a -> STM (IOSim s) a
TQueueDefault (IOSim s) a -> STM (IOSim s) a
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     = TQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
TQueueDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
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        = TQueue (IOSim s) a -> STM (IOSim s) a
TQueueDefault (IOSim s) a -> STM (IOSim s) a
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     = TQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
TQueueDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
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       = TQueue (IOSim s) a -> STM (IOSim s) [a]
TQueueDefault (IOSim s) a -> STM (IOSim s) [a]
forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m [a]
flushTQueueDefault
  writeTQueue :: forall a. TQueue (IOSim s) a -> a -> STM (IOSim s) ()
writeTQueue       = TQueue (IOSim s) a -> a -> STM (IOSim s) ()
TQueueDefault (IOSim s) a -> a -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> a -> STM m ()
writeTQueueDefault
  isEmptyTQueue :: forall a. TQueue (IOSim s) a -> STM (IOSim s) Bool
isEmptyTQueue     = TQueue (IOSim s) a -> STM (IOSim s) Bool
TQueueDefault (IOSim s) a -> STM (IOSim s) Bool
forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m Bool
isEmptyTQueueDefault
  unGetTQueue :: forall a. TQueue (IOSim s) a -> a -> STM (IOSim s) ()
unGetTQueue       = TQueue (IOSim s) a -> a -> STM (IOSim s) ()
TQueueDefault (IOSim s) a -> a -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> a -> STM m ()
unGetTQueueDefault

  newTBQueue :: forall a. Natural -> STM (IOSim s) (TBQueue (IOSim s) a)
newTBQueue        = Natural -> STM (IOSim s) (TBQueue (IOSim s) a)
Natural -> STM (IOSim s) (TBQueueDefault (IOSim s) a)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (TBQueueDefault m a)
newTBQueueDefault
  readTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) a
readTBQueue       = TBQueue (IOSim s) a -> STM (IOSim s) a
TBQueueDefault (IOSim s) a -> STM (IOSim s) a
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    = TBQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
TBQueueDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
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       = TBQueue (IOSim s) a -> STM (IOSim s) a
TBQueueDefault (IOSim s) a -> STM (IOSim s) a
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    = TBQueue (IOSim s) a -> STM (IOSim s) (Maybe a)
TBQueueDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
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      = TBQueue (IOSim s) a -> STM (IOSim s) [a]
TBQueueDefault (IOSim s) a -> STM (IOSim s) [a]
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m [a]
flushTBQueueDefault
  writeTBQueue :: forall a. TBQueue (IOSim s) a -> a -> STM (IOSim s) ()
writeTBQueue      = TBQueue (IOSim s) a -> a -> STM (IOSim s) ()
TBQueueDefault (IOSim s) a -> a -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> a -> STM m ()
writeTBQueueDefault
  lengthTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) Natural
lengthTBQueue     = TBQueue (IOSim s) a -> STM (IOSim s) Natural
TBQueueDefault (IOSim s) a -> STM (IOSim s) Natural
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Natural
lengthTBQueueDefault
  isEmptyTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) Bool
isEmptyTBQueue    = TBQueue (IOSim s) a -> STM (IOSim s) Bool
TBQueueDefault (IOSim s) a -> STM (IOSim s) Bool
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isEmptyTBQueueDefault
  isFullTBQueue :: forall a. TBQueue (IOSim s) a -> STM (IOSim s) Bool
isFullTBQueue     = TBQueue (IOSim s) a -> STM (IOSim s) Bool
TBQueueDefault (IOSim s) a -> STM (IOSim s) Bool
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isFullTBQueueDefault
  unGetTBQueue :: forall a. TBQueue (IOSim s) a -> a -> STM (IOSim s) ()
unGetTBQueue      = TBQueue (IOSim s) a -> a -> STM (IOSim s) ()
TBQueueDefault (IOSim s) a -> a -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> a -> STM m ()
unGetTBQueueDefault

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

  newTChan :: forall a. STM (IOSim s) (TChan (IOSim s) a)
newTChan          = STM (IOSim s) (TChanDefault (IOSim s) a)
STM (IOSim s) (TChan (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => STM m (TChanDefault m a)
MonadSTM.newTChanDefault
  newBroadcastTChan :: forall a. STM (IOSim s) (TChan (IOSim s) a)
newBroadcastTChan = STM (IOSim s) (TChanDefault (IOSim s) a)
STM (IOSim s) (TChan (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => STM m (TChanDefault m a)
MonadSTM.newBroadcastTChanDefault
  writeTChan :: forall a. TChan (IOSim s) a -> a -> STM (IOSim s) ()
writeTChan        = TChanDefault (IOSim s) a -> a -> STM (IOSim s) ()
TChan (IOSim s) a -> a -> STM (IOSim s) ()
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         = TChanDefault (IOSim s) a -> STM (IOSim s) a
TChan (IOSim s) a -> STM (IOSim s) a
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      = TChanDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
TChan (IOSim s) a -> STM (IOSim s) (Maybe a)
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         = TChanDefault (IOSim s) a -> STM (IOSim s) a
TChan (IOSim s) a -> STM (IOSim s) a
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      = TChanDefault (IOSim s) a -> STM (IOSim s) (Maybe a)
TChan (IOSim s) a -> STM (IOSim s) (Maybe a)
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          = TChanDefault (IOSim s) a
-> STM (IOSim s) (TChanDefault (IOSim s) a)
TChan (IOSim s) a -> STM (IOSim s) (TChan (IOSim s) a)
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        = TChanDefault (IOSim s) a -> a -> STM (IOSim s) ()
TChan (IOSim s) a -> a -> STM (IOSim s) ()
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      = TChanDefault (IOSim s) a -> STM (IOSim s) Bool
TChan (IOSim s) a -> STM (IOSim s) Bool
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        = TChanDefault (IOSim s) a
-> STM (IOSim s) (TChanDefault (IOSim s) a)
TChan (IOSim s) a -> STM (IOSim s) (TChan (IOSim s) a)
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 :: forall s a. TVar s a -> STRef s a
tvarCurrent :: STRef s a
tvarCurrent }  = STRef s a -> ST s a
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 :: forall s a. TVar s a -> STRef s a
tvarCurrent :: STRef s (Maybe a)
tvarCurrent }) = STRef s (Maybe a) -> ST s (Maybe a)
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 r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (() -> StmA s r) -> StmA s r) -> STM s ())
-> (forall r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> TVar s a
-> (Maybe a -> a -> ST s TraceValue) -> StmA s r -> StmA s r
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 s a
tvar Maybe a -> a -> ST s TraceValue
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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k ->
                               ST s () -> (() -> SimA s r) -> SimA s r
forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ( ST s () -> ST s ()
forall s a. ST s a -> ST s a
lazyToStrictST (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                                        STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
-> Maybe (Maybe a -> a -> ST s TraceValue) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (TVar s a -> STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
forall s a.
TVar s a -> STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace TVar (IOSim s) a
TVar s a
tvar) (Maybe (Maybe a -> a -> ST s TraceValue) -> ST s ())
-> Maybe (Maybe a -> a -> ST s TraceValue) -> ST s ()
forall a b. (a -> b) -> a -> b
$! (Maybe a -> a -> ST s TraceValue)
-> Maybe (Maybe a -> a -> ST s TraceValue)
forall a. a -> Maybe a
Just Maybe a -> a -> ST s TraceValue
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  = proxy (IOSim s)
-> TQueue (IOSim s) a
-> (Maybe [a] -> [a] -> InspectMonad (IOSim s) TraceValue)
-> STM (IOSim s) ()
proxy (IOSim s)
-> TQueueDefault (IOSim s) a
-> (Maybe [a] -> [a] -> InspectMonad (IOSim s) TraceValue)
-> STM (IOSim s) ()
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 = proxy (IOSim s)
-> TBQueue (IOSim s) a
-> (Maybe [a] -> [a] -> InspectMonad (IOSim s) TraceValue)
-> STM (IOSim s) ()
proxy (IOSim s)
-> TBQueueDefault (IOSim s) a
-> (Maybe [a] -> [a] -> InspectMonad (IOSim s) TraceValue)
-> STM (IOSim s) ()
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 = IOSim s (MVar (IOSim s) a)
IOSim s (MVarDefault (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => m (MVarDefault m a)
newEmptyMVarDefault
  newMVar :: forall a. a -> IOSim s (MVar (IOSim s) a)
newMVar      = a -> IOSim s (MVar (IOSim s) a)
a -> IOSim s (MVarDefault (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (MVarDefault m a)
newMVarDefault
  takeMVar :: forall a. MVar (IOSim s) a -> IOSim s a
takeMVar     = MVar (IOSim s) a -> IOSim s a
MVarDefault (IOSim s) a -> IOSim s a
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      = MVar (IOSim s) a -> a -> IOSim s ()
MVarDefault (IOSim s) a -> a -> IOSim s ()
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  = MVar (IOSim s) a -> IOSim s (Maybe a)
MVarDefault (IOSim s) a -> IOSim s (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> m (Maybe a)
tryTakeMVarDefault
  tryPutMVar :: forall a. MVar (IOSim s) a -> a -> IOSim s Bool
tryPutMVar   = MVar (IOSim s) a -> a -> IOSim s Bool
MVarDefault (IOSim s) a -> a -> IOSim s Bool
forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> a -> m Bool
tryPutMVarDefault
  readMVar :: forall a. MVar (IOSim s) a -> IOSim s a
readMVar     = MVar (IOSim s) a -> IOSim s a
MVarDefault (IOSim s) a -> IOSim s a
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  = MVar (IOSim s) a -> IOSim s (Maybe a)
MVarDefault (IOSim s) a -> IOSim s (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> m (Maybe a)
tryReadMVarDefault
  isEmptyMVar :: forall a. MVar (IOSim s) a -> IOSim s Bool
isEmptyMVar  = MVar (IOSim s) a -> IOSim s Bool
MVarDefault (IOSim s) a -> IOSim s Bool
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 <- proxy (IOSim s)
-> TVar (IOSim s) (MVarState (IOSim s) a)
-> InspectMonad (IOSim s) (MVarState (IOSim s) a)
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadInspectSTM m =>
proxy m -> TVar m a -> InspectMonad m a
forall (proxy :: (* -> *) -> *) a.
proxy (IOSim s) -> TVar (IOSim s) a -> InspectMonad (IOSim s) 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))
_ -> Maybe a -> ST s (Maybe a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        MVarFull a
x Deque (a, TVar (IOSim s) Bool)
_  -> Maybe a -> ST s (Maybe a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
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 IOSimThreadId -> IOSimThreadId -> Bool
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)
_) = IOSimThreadId -> IOSimThreadId -> Ordering
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) = IOSimThreadId -> STM s (Either SomeException b) -> Async s b
forall s a.
IOSimThreadId -> STM s (Either SomeException a) -> Async s a
Async IOSimThreadId
tid ((a -> b) -> Either SomeException a -> Either SomeException b
forall a b.
(a -> b) -> Either SomeException a -> Either SomeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either SomeException a -> Either SomeException b)
-> STM s (Either SomeException a) -> STM s (Either SomeException b)
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 <- IOSim s (TMVarDefault (IOSim s) (Either SomeException a))
IOSim s (TMVar (IOSim s) (Either SomeException a))
forall a. IOSim s (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
MonadSTM.newEmptyTMVarIO
    IOSimThreadId
tid <- ((forall b. IOSim s b -> IOSim s b) -> IOSim s IOSimThreadId)
-> IOSim s IOSimThreadId
forall b.
((forall b. IOSim s b -> IOSim s b) -> IOSim s b) -> IOSim s b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall b. IOSim s b -> IOSim s b) -> IOSim s IOSimThreadId)
 -> IOSim s IOSimThreadId)
-> ((forall b. IOSim s b -> IOSim s b) -> IOSim s IOSimThreadId)
-> IOSim s IOSimThreadId
forall a b. (a -> b) -> a -> b
$ \forall b. IOSim s b -> IOSim s b
restore ->
             IOSim s () -> IOSim s (ThreadId (IOSim s))
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (IOSim s () -> IOSim s (ThreadId (IOSim s)))
-> IOSim s () -> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ IOSim s a -> IOSim s (Either SomeException a)
forall e a. Exception e => IOSim s a -> IOSim s (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IOSim s a -> IOSim s a
forall b. IOSim s b -> IOSim s b
restore IOSim s a
action)
                  IOSim s (Either SomeException a)
-> (Either SomeException a -> IOSim s ()) -> IOSim s ()
forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM (IOSim s) () -> IOSim s ()
STM s () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
MonadSTM.atomically (STM s () -> IOSim s ())
-> (Either SomeException a -> STM s ())
-> Either SomeException a
-> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (IOSim s) (Either SomeException a)
-> Either SomeException a -> STM (IOSim s) ()
forall a. TMVar (IOSim s) a -> a -> STM (IOSim s) ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
MonadSTM.putTMVar TMVarDefault (IOSim s) (Either SomeException a)
TMVar (IOSim s) (Either SomeException a)
var
    TMVar (IOSim s) (Either SomeException a) -> String -> IOSim s ()
forall a. TMVar (IOSim s) a -> String -> IOSim s ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TMVar m a -> String -> m ()
MonadSTM.labelTMVarIO TMVarDefault (IOSim s) (Either SomeException a)
TMVar (IOSim s) (Either SomeException a)
var (String
"async-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOSimThreadId -> String
forall a. Show a => a -> String
show IOSimThreadId
tid)
    Async s a -> IOSim s (Async s a)
forall a. a -> IOSim s a
forall (m :: * -> *) a. Monad m => a -> m a
return (IOSimThreadId -> STM s (Either SomeException a) -> Async s a
forall s a.
IOSimThreadId -> STM s (Either SomeException a) -> Async s a
Async IOSimThreadId
tid (TMVar (IOSim s) (Either SomeException a)
-> STM (IOSim s) (Either SomeException a)
forall a. TMVar (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
MonadSTM.readTMVar TMVarDefault (IOSim s) (Either SomeException a)
TMVar (IOSim s) (Either SomeException a)
var))

  asyncOn :: forall a. Int -> IOSim s a -> IOSim s (Async (IOSim s) a)
asyncOn Int
_  = IOSim s a -> IOSim s (Async (IOSim s) a)
forall a. IOSim s a -> IOSim s (Async (IOSim s) a)
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 = IOSim s a -> IOSim s (Async (IOSim s) a)
forall a. IOSim s a -> IOSim s (Async (IOSim s) a)
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)
_) = ThreadId (IOSim s)
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 (IOSim s) (Either SomeException a)
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) = (Either SomeException a -> Maybe (Either SomeException a)
forall a. a -> Maybe a
Just (Either SomeException a -> Maybe (Either SomeException a))
-> STM s (Either SomeException a)
-> STM s (Maybe (Either SomeException a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s (Either SomeException a)
w) STM (IOSim s) (Maybe (Either SomeException a))
-> STM (IOSim s) (Maybe (Either SomeException a))
-> STM (IOSim s) (Maybe (Either SomeException a))
forall a. STM (IOSim s) a -> STM (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`MonadSTM.orElse` Maybe (Either SomeException a)
-> STM s (Maybe (Either SomeException a))
forall a. a -> STM s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either SomeException a)
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)
_) = ThreadId (IOSim s) -> AsyncCancelled -> IOSim s ()
forall e. Exception e => ThreadId (IOSim s) -> e -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
IOSimThreadId
tid AsyncCancelled
AsyncCancelled IOSim s () -> IOSim s (Either SomeException a) -> IOSim s ()
forall a b. IOSim s a -> IOSim s b -> IOSim s a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async (IOSim s) a -> IOSim s (Either SomeException a)
forall a. Async (IOSim s) a -> IOSim s (Either SomeException 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 = ThreadId (IOSim s) -> e -> IOSim s ()
forall e. Exception e => ThreadId (IOSim s) -> e -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
IOSimThreadId
tid e
e IOSim s () -> IOSim s (Either SomeException a) -> IOSim s ()
forall a b. IOSim s a -> IOSim s b -> IOSim s a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async (IOSim s) a -> IOSim s (Either SomeException a)
forall a. Async (IOSim s) a -> IOSim s (Either SomeException 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 = IOSim s a -> IOSim s (Async (IOSim s) a)
forall a. IOSim s a -> IOSim s (Async (IOSim s) a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async ((forall b. IOSim s b -> IOSim s b) -> IOSim s a
k IOSim s b -> IOSim s b
forall b. IOSim s b -> IOSim s b
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 = IOSim s a -> IOSim s (Async (IOSim s) a)
forall a. IOSim s a -> IOSim s (Async (IOSim s) a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async ((forall b. IOSim s b -> IOSim s b) -> IOSim s a
k IOSim s b -> IOSim s b
forall b. IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
unblock)

-- | This provides access to (almost) everything from the
-- @primitive@ package, but don't try to use the @MVar@s as that will not
-- work as expected.
--
-- @since 1.4.1.0
instance Prim.PrimMonad (IOSim s) where
  type PrimState (IOSim s) = s
  primitive :: forall a.
(State# (PrimState (IOSim s))
 -> (# State# (PrimState (IOSim s)), a #))
-> IOSim s a
primitive State# (PrimState (IOSim s))
-> (# State# (PrimState (IOSim s)), a #)
st = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> ST s a -> (a -> SimA s r) -> SimA s r
forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ((State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
-> ST s a
forall a.
(State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
-> ST s a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
Prim.primitive State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #)
State# (PrimState (IOSim s))
-> (# State# (PrimState (IOSim s)), a #)
st) a -> SimA s r
k

instance MonadST (IOSim s) where
  stToIO :: forall a. ST (PrimState (IOSim s)) a -> IOSim s a
stToIO ST (PrimState (IOSim s)) a
f = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> ST s a -> (a -> SimA s r) -> SimA s r
forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ST s a
ST (PrimState (IOSim s)) a
f a -> SimA s r
k
  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 a. ST s a -> IOSim s a) -> b
forall s. (forall a. ST s a -> IOSim s a) -> b
f ST s a -> IOSim s a
forall a. ST s a -> IOSim s a
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
-- 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 r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r)
-> ((a -> SimA s r) -> SimA s r) -> (a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> ST s a -> (a -> SimA s r) -> SimA s r
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 r. (Word64 -> SimA s r) -> SimA s r) -> IOSim s Word64
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Word64 -> SimA s r) -> SimA s r) -> IOSim s Word64)
-> (forall r. (Word64 -> SimA s r) -> SimA s r) -> IOSim s Word64
forall a b. (a -> b) -> a -> b
$ ((Word64 -> SimA s r) -> SimA s r)
-> (Word64 -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((Word64 -> SimA s r) -> SimA s r)
 -> (Word64 -> SimA s r) -> SimA s r)
-> ((Word64 -> SimA s r) -> SimA s r)
-> (Word64 -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \Word64 -> SimA s r
k -> (Time -> SimA s r) -> SimA s r
forall s b. (Time -> SimA s b) -> SimA s b
GetMonoTime (Word64 -> SimA s r
k (Word64 -> SimA s r) -> (Time -> Word64) -> Time -> SimA s r
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) = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DiffTime -> Integer
diffTimeToPicoseconds DiffTime
d Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000)

instance MonadMonotonicTime (IOSim s) where
  getMonotonicTime :: IOSim s Time
getMonotonicTime = (forall r. (Time -> SimA s r) -> SimA s r) -> IOSim s Time
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Time -> SimA s r) -> SimA s r) -> IOSim s Time)
-> (forall r. (Time -> SimA s r) -> SimA s r) -> IOSim s Time
forall a b. (a -> b) -> a -> b
$ ((Time -> SimA s r) -> SimA s r) -> (Time -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((Time -> SimA s r) -> SimA s r)
 -> (Time -> SimA s r) -> SimA s r)
-> ((Time -> SimA s r) -> SimA s r)
-> (Time -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \Time -> SimA s r
k -> (Time -> SimA s r) -> SimA s r
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 r. (UTCTime -> SimA s r) -> SimA s r) -> IOSim s UTCTime
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (UTCTime -> SimA s r) -> SimA s r) -> IOSim s UTCTime)
-> (forall r. (UTCTime -> SimA s r) -> SimA s r) -> IOSim s UTCTime
forall a b. (a -> b) -> a -> b
$ ((UTCTime -> SimA s r) -> SimA s r)
-> (UTCTime -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((UTCTime -> SimA s r) -> SimA s r)
 -> (UTCTime -> SimA s r) -> SimA s r)
-> ((UTCTime -> SimA s r) -> SimA s r)
-> (UTCTime -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \UTCTime -> SimA s r
k -> (UTCTime -> SimA s r) -> SimA s r
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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> UTCTime -> SimA s r -> SimA s r
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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> SimA s r -> SimA s r
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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> DiffTime -> SimA s r -> SimA s r
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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> DiffTime -> SimA s r -> SimA s r
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 r. (Timeout s -> SimA s r) -> SimA s r)
-> IOSim s (Timeout s)
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Timeout s -> SimA s r) -> SimA s r)
 -> IOSim s (Timeout s))
-> (forall r. (Timeout s -> SimA s r) -> SimA s r)
-> IOSim s (Timeout s)
forall a b. (a -> b) -> a -> b
$ ((Timeout s -> SimA s r) -> SimA s r)
-> (Timeout s -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((Timeout s -> SimA s r) -> SimA s r)
 -> (Timeout s -> SimA s r) -> SimA s r)
-> ((Timeout s -> SimA s r) -> SimA s r)
-> (Timeout s -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \Timeout s -> SimA s r
k -> DiffTime -> (Timeout s -> SimA s r) -> SimA s r
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)     = TVar (IOSim s) TimeoutState -> STM (IOSim s) TimeoutState
forall a. TVar (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
MonadSTM.readTVar TVar (IOSim s) TimeoutState
TVar s TimeoutState
var
readTimeout (NegativeTimeout TimeoutId
_key) = TimeoutState -> STM s TimeoutState
forall a. a -> STM s a
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 r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r)
-> ((() -> SimA s r) -> SimA s r) -> (() -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> Timeout s -> SimA s r -> SimA s r
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 <- Timeout s -> STM s TimeoutState
forall s. Timeout s -> STM s TimeoutState
readTimeout Timeout s
t
                     case TimeoutState
s of
                       TimeoutState
TimeoutPending   -> STM (IOSim s) Bool
STM s Bool
forall a. STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                       TimeoutState
TimeoutFired     -> Bool -> STM s Bool
forall a. a -> STM s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                       TimeoutState
TimeoutCancelled -> Bool -> STM s Bool
forall a. a -> STM s a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0 = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IOSim s a -> IOSim s (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOSim s a
action
    | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe a -> IOSim s (Maybe a)
forall a. a -> IOSim s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise = (forall r. (Maybe a -> SimA s r) -> SimA s r) -> IOSim s (Maybe a)
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Maybe a -> SimA s r) -> SimA s r)
 -> IOSim s (Maybe a))
-> (forall r. (Maybe a -> SimA s r) -> SimA s r)
-> IOSim s (Maybe a)
forall a b. (a -> b) -> a -> b
$ ((Maybe a -> SimA s r) -> SimA s r)
-> (Maybe a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((Maybe a -> SimA s r) -> SimA s r)
 -> (Maybe a -> SimA s r) -> SimA s r)
-> ((Maybe a -> SimA s r) -> SimA s r)
-> (Maybe a -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \Maybe a -> SimA s r
k -> DiffTime -> SimA s a -> (Maybe a -> SimA s r) -> SimA s r
forall s a b.
DiffTime -> SimA s a -> (Maybe a -> SimA s b) -> SimA s b
StartTimeout DiffTime
d' (IOSim s a -> SimA s a
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 r. (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar (IOSim s) Bool)
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
 -> IOSim s (TVar (IOSim s) Bool))
-> (forall r. (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar (IOSim s) Bool)
forall a b. (a -> b) -> a -> b
$ ((TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> (TVar (IOSim s) Bool -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
 -> (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> ((TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> (TVar (IOSim s) Bool -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \TVar (IOSim s) Bool -> SimA s r
k -> DiffTime -> (TVar s Bool -> SimA s r) -> SimA s r
forall s b. DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b
RegisterDelay DiffTime
d' TVar (IOSim s) Bool -> SimA s r
TVar 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 DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<  DiffTime
0 = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IOSim s a -> IOSim s (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOSim s a
action
    | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== DiffTime
0 = Maybe a -> IOSim s (Maybe a)
forall a. a -> IOSim s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise = (forall r. (Maybe a -> SimA s r) -> SimA s r) -> IOSim s (Maybe a)
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Maybe a -> SimA s r) -> SimA s r)
 -> IOSim s (Maybe a))
-> (forall r. (Maybe a -> SimA s r) -> SimA s r)
-> IOSim s (Maybe a)
forall a b. (a -> b) -> a -> b
$ ((Maybe a -> SimA s r) -> SimA s r)
-> (Maybe a -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((Maybe a -> SimA s r) -> SimA s r)
 -> (Maybe a -> SimA s r) -> SimA s r)
-> ((Maybe a -> SimA s r) -> SimA s r)
-> (Maybe a -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \Maybe a -> SimA s r
k -> DiffTime -> SimA s a -> (Maybe a -> SimA s r) -> SimA s r
forall s a b.
DiffTime -> SimA s a -> (Maybe a -> SimA s b) -> SimA s b
StartTimeout DiffTime
d (IOSim s a -> SimA s a
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 r. (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar (IOSim s) Bool)
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
 -> IOSim s (TVar (IOSim s) Bool))
-> (forall r. (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar (IOSim s) Bool)
forall a b. (a -> b) -> a -> b
$ ((TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> (TVar (IOSim s) Bool -> SimA s r) -> SimA s r
forall a b. (a -> b) -> a -> b
oneShot (((TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
 -> (TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> ((TVar (IOSim s) Bool -> SimA s r) -> SimA s r)
-> (TVar (IOSim s) Bool -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \TVar (IOSim s) Bool -> SimA s r
k -> DiffTime -> (TVar s Bool -> SimA s r) -> SimA s r
forall s b. DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b
RegisterDelay DiffTime
d TVar (IOSim s) Bool -> SimA s r
TVar s Bool -> SimA s r
k
  registerDelayCancellable :: DiffTime -> IOSim s (STM (IOSim s) TimeoutState, IOSim s ())
registerDelayCancellable DiffTime
d = do
    Timeout s
t <- DiffTime -> IOSim s (Timeout s)
forall s. DiffTime -> IOSim s (Timeout s)
newTimeout DiffTime
d
    (STM s TimeoutState, IOSim s ())
-> IOSim s (STM s TimeoutState, IOSim s ())
forall a. a -> IOSim s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Timeout s -> STM s TimeoutState
forall s. Timeout s -> STM s TimeoutState
readTimeout Timeout s
t, Timeout s -> IOSim s ()
forall s. Timeout s -> IOSim s ()
cancelTimeout Timeout s
t)

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

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

instance Exception TimeoutException where
  toException :: TimeoutException -> SomeException
toException   = TimeoutException -> SomeException
forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe TimeoutException
fromException = SomeException -> Maybe TimeoutException
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 = EventlogEvent -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM (EventlogEvent -> IOSim s ())
-> (String -> EventlogEvent) -> String -> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EventlogEvent
EventlogEvent
  traceMarkerIO :: String -> IOSim s ()
traceMarkerIO = EventlogMarker -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM (EventlogMarker -> IOSim s ())
-> (String -> EventlogMarker) -> String -> IOSim s ()
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. SimEvent -> Rep SimEvent x)
-> (forall x. Rep SimEvent x -> SimEvent) -> Generic SimEvent
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
$cfrom :: forall x. SimEvent -> Rep SimEvent x
from :: forall x. SimEvent -> Rep SimEvent x
$cto :: forall x. Rep SimEvent x -> SimEvent
to :: forall x. Rep SimEvent x -> SimEvent
Generic
  deriving Int -> SimEvent -> String -> String
[SimEvent] -> String -> String
SimEvent -> String
(Int -> SimEvent -> String -> String)
-> (SimEvent -> String)
-> ([SimEvent] -> String -> String)
-> Show SimEvent
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SimEvent -> String -> String
showsPrec :: Int -> SimEvent -> String -> String
$cshow :: SimEvent -> String
show :: SimEvent -> String
$cshowList :: [SimEvent] -> String -> String
showList :: [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 :: SimEvent -> IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel :: Maybe String
seThreadLabel, SimEventType
seType :: SimEvent -> SimEventType
seType :: SimEventType
seType} =
    String
-> Int
-> String
-> Int
-> String
-> Int
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s"
           Int
timeWidth
           (DiffTime -> String
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 = String -> Maybe String -> String
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 :: SimEvent -> IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId, Int
seStep :: SimEvent -> Int
seStep :: Int
seStep, Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel :: Maybe String
seThreadLabel, SimEventType
seType :: SimEvent -> SimEventType
seType :: SimEventType
seType} =
    String
-> Int
-> String
-> Int
-> String
-> Int
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s"
           Int
timeWidth
           (DiffTime -> String
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 = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
seThreadLabel

ppSimEvent Int
_ Int
_ Int
_ (SimRacesFound [ScheduleControl]
controls) =
    String
"RacesFound "String -> String -> String
forall a. [a] -> [a] -> [a]
++[ScheduleControl] -> String
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
    -- ^ An `IOSim` bug, please report to <https://github.com/input-output-hk/io-sim>
    deriving (Int -> SimResult a -> String -> String
[SimResult a] -> String -> String
SimResult a -> String
(Int -> SimResult a -> String -> String)
-> (SimResult a -> String)
-> ([SimResult a] -> String -> String)
-> Show (SimResult a)
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
$cshowsPrec :: forall a. Show a => Int -> SimResult a -> String -> String
showsPrec :: Int -> SimResult a -> String -> String
$cshow :: forall a. Show a => SimResult a -> String
show :: SimResult a -> String
$cshowList :: forall a. Show a => [SimResult a] -> String -> String
showList :: [SimResult a] -> String -> String
Show, (forall a b. (a -> b) -> SimResult a -> SimResult b)
-> (forall a b. a -> SimResult b -> SimResult a)
-> Functor SimResult
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
$cfmap :: forall a b. (a -> b) -> SimResult a -> SimResult b
fmap :: forall a b. (a -> b) -> SimResult a -> SimResult b
$c<$ :: forall a b. a -> SimResult b -> SimResult a
<$ :: forall a b. a -> SimResult b -> SimResult a
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 ->
      String
-> Int
-> String
-> Int
-> String
-> Int
-> String
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s %s"
             Int
timeWidth
             (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
time)
             Int
tidWidth
             (IOSimThreadId -> String
ppIOSimThreadId (Labelled IOSimThreadId -> IOSimThreadId
forall a. Labelled a -> a
l_labelled Labelled IOSimThreadId
tid))
             Int
thLabelWidth
             (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Labelled IOSimThreadId -> Maybe String
forall a. Labelled a -> Maybe String
l_label Labelled IOSimThreadId
tid)
             (String
"MainReturn " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a)
             (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Context -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((IOSimThreadId -> String) -> Labelled IOSimThreadId -> String
forall a. (a -> String) -> Labelled a -> String
ppLabelled IOSimThreadId -> String
ppIOSimThreadId (Labelled IOSimThreadId -> String)
-> [Labelled IOSimThreadId] -> Context
forall a b. (a -> b) -> [a] -> [b]
`map` [Labelled IOSimThreadId]
tids) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]")
    MainException (Time DiffTime
time) Labelled IOSimThreadId
tid SomeException
e [Labelled IOSimThreadId]
tids ->
      String
-> Int
-> String
-> Int
-> String
-> Int
-> String
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s %s"
             Int
timeWidth
             (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
time)
             Int
tidWidth
             (IOSimThreadId -> String
ppIOSimThreadId (Labelled IOSimThreadId -> IOSimThreadId
forall a. Labelled a -> a
l_labelled Labelled IOSimThreadId
tid))
             Int
thLabelWidth
             (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Labelled IOSimThreadId -> Maybe String
forall a. Labelled a -> Maybe String
l_label Labelled IOSimThreadId
tid)
             (String
"MainException " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
             (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Context -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((IOSimThreadId -> String) -> Labelled IOSimThreadId -> String
forall a. (a -> String) -> Labelled a -> String
ppLabelled IOSimThreadId -> String
ppIOSimThreadId (Labelled IOSimThreadId -> String)
-> [Labelled IOSimThreadId] -> Context
forall a b. (a -> b) -> [a] -> [b]
`map` [Labelled IOSimThreadId]
tids) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]")
    Deadlock (Time DiffTime
time) [Labelled IOSimThreadId]
tids ->
      String
-> Int
-> String
-> Int
-> String
-> Int
-> String
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s %s"
             Int
timeWidth
             (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
time)
             Int
tidWidth
             String
""
             Int
thLabelWidth
             String
""
             String
"Deadlock"
             (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Context -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((IOSimThreadId -> String) -> Labelled IOSimThreadId -> String
forall a. (a -> String) -> Labelled a -> String
ppLabelled IOSimThreadId -> String
ppIOSimThreadId (Labelled IOSimThreadId -> String)
-> [Labelled IOSimThreadId] -> Context
forall a b. (a -> b) -> [a] -> [b]
`map` [Labelled IOSimThreadId]
tids) String -> String -> String
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
e String -> String -> String
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.
--
-- Note: this is not a streaming function, it will evaluate the whole trace
-- before printing it.  If you need to print a very large trace, you might want
-- to use
--
-- @'Trace.ppTrace' show ('ppSimEvent' 0 0 0)@
--
ppTrace :: Show a => SimTrace a -> String
ppTrace :: forall a. Show a => SimTrace a -> String
ppTrace SimTrace a
tr = (SimResult a -> String)
-> (SimEvent -> String) -> SimTrace a -> String
forall a b. (a -> String) -> (b -> String) -> Trace a b -> String
Trace.ppTrace
               (Int -> Int -> Int -> SimResult a -> String
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) =
        Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int)
-> (Max Int, Max Int, Max Int)
forall (t :: * -> * -> *) a. (Bifoldable t, Ord a) => t a a -> a
bimaximum
      (Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int)
 -> (Max Int, Max Int, Max Int))
-> (SimTrace a
    -> Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int))
-> SimTrace a
-> (Max Int, Max Int, Max Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimResult a -> (Max Int, Max Int, Max Int))
-> (SimEvent -> (Max Int, Max Int, Max Int))
-> SimTrace a
-> Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int)
forall a b c d. (a -> b) -> (c -> d) -> Trace a c -> Trace b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Max Int, Max Int, Max Int)
-> SimResult a -> (Max Int, Max Int, Max Int)
forall a b. a -> b -> a
const (Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0))
              (\SimEvent
a -> case SimEvent
a of
                SimEvent {seTime :: SimEvent -> Time
seTime = Time DiffTime
time, IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel :: Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
time))
                  , Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (IOSimThreadId -> String
forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> Int
forall a. Maybe a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimPOREvent {seTime :: SimEvent -> Time
seTime = Time DiffTime
time, IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel :: Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
time))
                  , Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (IOSimThreadId -> String
forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> Int
forall a. Maybe a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimRacesFound {} ->
                  (Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0)
              )
      (SimTrace a -> (Max Int, Max Int, Max Int))
-> SimTrace a -> (Max Int, Max Int, Max Int)
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 = (SimResult a -> String)
-> (SimEvent -> String) -> SimTrace a -> String
forall a b. (a -> String) -> (b -> String) -> Trace a b -> String
Trace.ppTrace
                (String -> SimResult a -> String
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) =
        Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int)
-> (Max Int, Max Int, Max Int)
forall (t :: * -> * -> *) a. (Bifoldable t, Ord a) => t a a -> a
bimaximum
      (Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int)
 -> (Max Int, Max Int, Max Int))
-> (SimTrace a
    -> Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int))
-> SimTrace a
-> (Max Int, Max Int, Max Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimResult a -> (Max Int, Max Int, Max Int))
-> (SimEvent -> (Max Int, Max Int, Max Int))
-> SimTrace a
-> Trace (Max Int, Max Int, Max Int) (Max Int, Max Int, Max Int)
forall a b c d. (a -> b) -> (c -> d) -> Trace a c -> Trace b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Max Int, Max Int, Max Int)
-> SimResult a -> (Max Int, Max Int, Max Int)
forall a b. a -> b -> a
const (Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0))
              (\SimEvent
a -> case SimEvent
a of
                SimEvent {Time
seTime :: SimEvent -> Time
seTime :: Time
seTime, IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel :: Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Time -> String
forall a. Show a => a -> String
show Time
seTime))
                  , Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (IOSimThreadId -> String
forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> Int
forall a. Maybe a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimPOREvent {Time
seTime :: SimEvent -> Time
seTime :: Time
seTime, IOSimThreadId
seThreadId :: SimEvent -> IOSimThreadId
seThreadId :: IOSimThreadId
seThreadId, Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel :: Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Time -> String
forall a. Show a => a -> String
show Time
seTime))
                  , Int -> Max Int
forall a. a -> Max a
Max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (IOSimThreadId -> String
forall a. Show a => a -> String
show (IOSimThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> Int
forall a. Maybe a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimRacesFound {} ->
                  (Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0, Int -> Max Int
forall a. a -> Max a
Max Int
0)
              )
      (SimTrace a -> (Max Int, Max Int, Max Int))
-> SimTrace a -> (Max Int, Max Int, Max Int)
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 = Endo x -> x -> x
forall a. Endo a -> a -> a
appEndo
        (Endo x -> x -> x)
-> (SimTrace a -> Endo x) -> SimTrace a -> x -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimEvent -> Endo x) -> [SimEvent] -> Endo x
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((x -> x) -> Endo x
forall a. (a -> a) -> Endo a
Endo ((x -> x) -> Endo x) -> (SimEvent -> x -> x) -> SimEvent -> Endo x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> x -> x
forall a. String -> a -> a
Debug.trace (String -> x -> x) -> (SimEvent -> String) -> SimEvent -> x -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimEvent -> String
forall a. Show a => a -> String
show)
        ([SimEvent] -> Endo x)
-> (SimTrace a -> [SimEvent]) -> SimTrace a -> Endo x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimTrace a -> [SimEvent]
forall a b. Trace a b -> [b]
Trace.toList


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

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

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

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

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

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

pattern TraceInternalError :: String -> SimTrace a
pattern $mTraceInternalError :: forall {r} {a}. SimTrace a -> (String -> r) -> ((# #) -> r) -> r
$bTraceInternalError :: forall a. String -> SimTrace a
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`)
  | 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
  -- ^ /IOSimPOR/ event: reschedule a thread following the given
  -- `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
(Int -> SimEventType -> String -> String)
-> (SimEventType -> String)
-> ([SimEventType] -> String -> String)
-> Show SimEventType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SimEventType -> String -> String
showsPrec :: Int -> SimEventType -> String -> String
$cshow :: SimEventType -> String
show :: SimEventType -> String
$cshowList :: [SimEventType] -> String -> String
showList :: [SimEventType] -> String -> String
Show

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

  EventTxAborted Maybe Effect
mbEff ->
    Context -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TxAborted",
             String -> (Effect -> String) -> Maybe Effect -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Effect -> String) -> Effect -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> String
ppEffect) Maybe Effect
mbEff ]
  EventTxBlocked [Labelled TVarId]
blocked Maybe Effect
mbEff ->
   Context -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TxBlocked ",
             (Labelled TVarId -> String) -> [Labelled TVarId] -> String
forall a. (a -> String) -> [a] -> String
ppList ((TVarId -> String) -> Labelled TVarId -> String
forall a. (a -> String) -> Labelled a -> String
ppLabelled TVarId -> String
forall a. Show a => a -> String
show) [Labelled TVarId]
blocked,
             String -> (Effect -> String) -> Maybe Effect -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Effect -> String) -> Effect -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> String
ppEffect) Maybe Effect
mbEff ]
  EventTxWakeup [Labelled TVarId]
changed ->
    String
"TxWakeup " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Labelled TVarId -> String) -> [Labelled TVarId] -> String
forall a. (a -> String) -> [a] -> String
ppList ((TVarId -> String) -> Labelled TVarId -> String
forall a. (a -> String) -> Labelled a -> String
ppLabelled TVarId -> String
forall a. Show a => a -> String
show) [Labelled TVarId]
changed
  EventUnblocked [IOSimThreadId]
unblocked ->
    String
"Unblocked " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (IOSimThreadId -> String) -> [IOSimThreadId] -> String
forall a. (a -> String) -> [a] -> String
ppList IOSimThreadId -> String
ppIOSimThreadId [IOSimThreadId]
unblocked
  EventThreadDelay TimeoutId
tid Time
t ->
    Context -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"ThreadDelay ",
             TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
tid, String
" ",
             Time -> String
forall a. Show a => a -> String
show Time
t ]
  EventThreadDelayFired  TimeoutId
tid -> String
"ThreadDelayFired " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
tid
  EventTimeoutCreated TimeoutId
timer IOSimThreadId
tid Time
t ->
    Context -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TimeoutCreated ",
             TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
timer, String
" ",
             IOSimThreadId -> String
ppIOSimThreadId IOSimThreadId
tid, String
" ",
             Time -> String
forall a. Show a => a -> String
show Time
t ]
  EventTimeoutFired TimeoutId
timer ->
    String
"TimeoutFired " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
timer
  EventRegisterDelayCreated TimeoutId
timer TVarId
tvarId Time
t ->
    Context -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"RegisterDelayCreated ",
             TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
timer, String
" ",
             TVarId -> String
forall a. Show a => a -> String
show TVarId
tvarId, String
" ",
             Time -> String
forall a. Show a => a -> String
show Time
t ]
  EventRegisterDelayFired TimeoutId
timer -> String
"RegisterDelayFired " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
timer
  EventTimerCreated TimeoutId
timer TVarId
tvarId Time
t ->
    Context -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"TimerCreated ",
              TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
timer, String
" ",
              TVarId -> String
forall a. Show a => a -> String
show TVarId
tvarId, String
" ",
              Time -> String
forall a. Show a => a -> String
show Time
t ]
  EventTimerCancelled TimeoutId
timer -> String
"TimerCancelled " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
timer
  EventTimerFired TimeoutId
timer -> String
"TimerFired " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TimeoutId -> String
forall a. Show a => a -> String
show TimeoutId
timer
  EventThreadStatus  IOSimThreadId
tid IOSimThreadId
tid' ->
    Context -> String
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScheduleControl -> String
forall a. Show a => a -> String
show ScheduleControl
a
  SimEventType
EventThreadSleep -> String
"ThreadSleep"
  SimEventType
EventThreadWake -> String
"ThreadWake"
  EventDeschedule Deschedule
a -> String
"Deschedule " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Deschedule -> String
forall a. Show a => a -> String
show Deschedule
a
  EventFollowControl ScheduleControl
a -> String
"FollowControl " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScheduleControl -> String
forall a. Show a => a -> String
show ScheduleControl
a
  EventAwaitControl (IOSimThreadId, Int)
s ScheduleControl
a ->
    Context -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"AwaitControl ",
             (IOSimThreadId, Int) -> String
ppStepId (IOSimThreadId, Int)
s, String
" ",
             ScheduleControl -> String
forall a. Show a => a -> String
show ScheduleControl
a ]
  EventPerformAction (IOSimThreadId, Int)
a -> String
"PerformAction " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (IOSimThreadId, Int) -> String
ppStepId (IOSimThreadId, Int)
a
  EventReschedule ScheduleControl
a -> String
"Reschedule " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScheduleControl -> String
forall a. Show a => a -> String
show ScheduleControl
a
  EventEffect VectorClock
clock Effect
eff ->
    Context -> String
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 -> Races -> String
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
(Labelled a -> Labelled a -> Bool)
-> (Labelled a -> Labelled a -> Bool) -> Eq (Labelled a)
forall a. Eq a => Labelled a -> Labelled a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Labelled a -> Labelled a -> Bool
Eq, Eq (Labelled a)
Eq (Labelled a) =>
(Labelled a -> Labelled a -> Ordering)
-> (Labelled a -> Labelled a -> Bool)
-> (Labelled a -> Labelled a -> Bool)
-> (Labelled a -> Labelled a -> Bool)
-> (Labelled a -> Labelled a -> Bool)
-> (Labelled a -> Labelled a -> Labelled a)
-> (Labelled a -> Labelled a -> Labelled a)
-> Ord (Labelled a)
Labelled a -> Labelled a -> Bool
Labelled a -> Labelled a -> Ordering
Labelled a -> Labelled a -> Labelled a
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
$ccompare :: forall a. Ord a => Labelled a -> Labelled a -> Ordering
compare :: Labelled a -> Labelled a -> Ordering
$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
>= :: Labelled a -> Labelled a -> Bool
$cmax :: forall a. Ord a => Labelled a -> Labelled a -> Labelled a
max :: Labelled a -> Labelled a -> Labelled a
$cmin :: forall a. Ord a => Labelled a -> Labelled a -> Labelled a
min :: Labelled a -> Labelled a -> Labelled a
Ord, (forall x. Labelled a -> Rep (Labelled a) x)
-> (forall x. Rep (Labelled a) x -> Labelled a)
-> Generic (Labelled a)
forall x. Rep (Labelled a) x -> Labelled a
forall x. Labelled a -> Rep (Labelled a) x
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
$cfrom :: forall a x. Labelled a -> Rep (Labelled a) x
from :: forall x. Labelled a -> Rep (Labelled a) x
$cto :: forall a x. Rep (Labelled a) x -> Labelled a
to :: forall x. Rep (Labelled a) x -> Labelled a
Generic)
  deriving Int -> Labelled a -> String -> String
[Labelled a] -> String -> String
Labelled a -> String
(Int -> Labelled a -> String -> String)
-> (Labelled a -> String)
-> ([Labelled a] -> String -> String)
-> Show (Labelled a)
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
$cshowsPrec :: forall a. Show a => Int -> Labelled a -> String -> String
showsPrec :: Int -> Labelled a -> String -> String
$cshow :: forall a. Show a => Labelled a -> String
show :: Labelled a -> String
$cshowList :: forall a. Show a => [Labelled a] -> String -> String
showList :: [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 } = Context -> String
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
(Int -> ExplorationOptions -> String -> String)
-> (ExplorationOptions -> String)
-> ([ExplorationOptions] -> String -> String)
-> Show ExplorationOptions
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ExplorationOptions -> String -> String
showsPrec :: Int -> ExplorationOptions -> String -> String
$cshow :: ExplorationOptions -> String
show :: ExplorationOptions -> String
$cshowList :: [ExplorationOptions] -> String -> String
showList :: [ExplorationOptions] -> String -> String
Show

stdExplorationOptions :: ExplorationOptions
stdExplorationOptions :: ExplorationOptions
stdExplorationOptions = ExplorationOptions{
    explorationScheduleBound :: Int
explorationScheduleBound = Int
100,
    explorationBranching :: Int
explorationBranching     = Int
3,
    explorationStepTimelimit :: Maybe Int
explorationStepTimelimit = Maybe Int
forall a. Maybe a
Nothing,
    explorationReplay :: Maybe ScheduleControl
explorationReplay        = Maybe ScheduleControl
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 = n}

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

withStepTimelimit :: Int -> ExplorationSpec
withStepTimelimit :: Int -> ExplorationSpec
withStepTimelimit Int
n ExplorationOptions
e = ExplorationOptions
e{explorationStepTimelimit = Just n}

withReplay :: ScheduleControl -> ExplorationSpec
withReplay :: ScheduleControl -> ExplorationSpec
withReplay ScheduleControl
r ExplorationOptions
e = ExplorationOptions
e{explorationReplay = Just r}