{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTSyntax                 #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeFamilies               #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-partial-fields          #-}

module Control.Monad.IOSim.Types
  ( IOSim (..)
  , runIOSim
  , traceM
  , traceSTM
  , liftST
  , SimA (..)
  , StepId
  , STMSim
  , STM (..)
  , runSTM
  , StmA (..)
  , StmTxResult (..)
  , StmStack (..)
  , Timeout (..)
  , TimeoutException (..)
  , setCurrentTime
  , unshareClock
  , ScheduleControl (..)
  , ScheduleMod (..)
  , ExplorationOptions (..)
  , ExplorationSpec
  , withScheduleBound
  , withBranching
  , withStepTimelimit
  , withReplay
  , stdExplorationOptions
  , EventlogEvent (..)
  , EventlogMarker (..)
  , SimEventType (..)
  , SimEvent (..)
  , SimResult (..)
  , SimTrace
  , Trace.Trace (Trace, SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceRacesFound, TraceLoop)
  , ppTrace
  , ppTrace_
  , ppSimEvent
  , ppDebug
  , TraceEvent
  , Labelled (..)
  , module Control.Monad.IOSim.CommonTypes
  , SimM
  , SimSTM
  ) where

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

import           Control.Monad.Class.MonadAsync hiding (Async)
import qualified Control.Monad.Class.MonadAsync as MonadAsync
import           Control.Monad.Class.MonadEventlog
import           Control.Monad.Class.MonadFork hiding (ThreadId)
import qualified Control.Monad.Class.MonadFork as MonadFork
import           Control.Monad.Class.MonadST
import           Control.Monad.Class.MonadSTM (MonadInspectSTM (..),
                     MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..),
                     TMVarDefault, TraceValue)
import qualified Control.Monad.Class.MonadSTM as MonadSTM
import           Control.Monad.Class.MonadSay
import           Control.Monad.Class.MonadTest
import           Control.Monad.Class.MonadThrow as MonadThrow hiding
                     (getMaskingState)
import qualified Control.Monad.Class.MonadThrow as MonadThrow
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer
import           Control.Monad.ST.Lazy
import qualified Control.Monad.ST.Strict as StrictST

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

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

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

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


import qualified System.IO.Error as IO.Error (userError)

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

type SimM s = IOSim s
{-# DEPRECATED SimM "Use IOSim" #-}

runIOSim :: IOSim s a -> SimA s a
runIOSim :: 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

traceM :: Typeable a => a -> IOSim s ()
traceM :: 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
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 ())

traceSTM :: Typeable a => a -> STMSim s ()
traceSTM :: a -> STMSim s ()
traceSTM a
x = (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
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 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

  NewTimeout   :: DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
  UpdateTimeout:: Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b
  CancelTimeout:: Timeout (IOSim 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 () -> (ThreadId -> SimA s b) -> SimA s b
  GetThreadId  :: (ThreadId -> SimA s b) -> SimA s b
  LabelThread  :: ThreadId -> String -> SimA s b -> SimA s b

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

  ThrowTo      :: SomeException -> ThreadId -> 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 { STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM :: forall r. (a -> StmA s r) -> StmA s r }

runSTM :: STM s a -> StmA s a
runSTM :: 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

  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

-- Exported type
type STMSim = STM

type SimSTM = STM
{-# DEPRECATED SimSTM "Use STMSim" #-}

--
-- Monad class instances
--

instance Functor (IOSim s) where
    {-# INLINE fmap #-}
    fmap :: (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
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 -> (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 :: 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
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 (<*>) #-}
    <*> :: 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
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) -> ((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 -> (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 (*>) #-}
    *> :: 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
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 -> (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 -> (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 :: a -> IOSim s a
return = a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>=) #-}
    >>= :: 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
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 -> (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 -> (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 (>>) #-}
    >> :: IOSim s a -> IOSim s b -> IOSim s 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 (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 (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 :: 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
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 :: (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
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 x s r. (x -> IOSim s x) -> (x -> SimA s r) -> SimA s r
Fix a -> IOSim s a
f a -> SimA s r
k


instance Functor (STM s) where
    {-# INLINE fmap #-}
    fmap :: (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
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 -> (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 :: 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
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 (<*>) #-}
    <*> :: 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
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) -> ((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 -> (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 (*>) #-}
    *> :: 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
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 -> (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 -> (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 :: a -> STM s a
return = a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>=) #-}
    >>= :: 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
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 -> (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 -> (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 (>>) #-}
    >> :: STM s a -> STM s b -> STM s 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 :: 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
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 :: STM s a
empty = STM s a
forall (m :: * -> *) a. MonadSTM m => STM m a
MonadSTM.retry
    <|> :: STM s a -> STM s a -> STM s a
(<|>) = STM s a -> STM s a -> STM s a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
MonadSTM.orElse

instance MonadPlus (STM s) where

instance 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
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 :: 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
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 :: 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
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

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

instance MonadThrow (STM s) where
  throwIO :: 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
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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return c
r

  finally :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
r

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

instance MonadCatch (IOSim s) where
  catch :: 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
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 e s a b.
Exception e =>
SimA s a -> (e -> 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 :: IOSim s a -> (e -> IOSim s a) -> IOSim s a
catch = 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 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 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 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 forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
blockUninterruptible

  uninterruptibleMask :: ((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 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 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 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

instance Exceptions.MonadMask (IOSim s) where
  mask :: ((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 (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.mask
  uninterruptibleMask :: ((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 (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.uninterruptibleMask

  generalBracket :: 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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)


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

getMaskingStateImpl :: 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  forall r. (MaskingState -> SimA s r) -> SimA s r
forall s b. (MaskingState -> SimA s b) -> SimA s b
GetMaskState
unblock :: 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 :: 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 :: 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) = ThreadId
  myThreadId :: IOSim s (ThreadId (IOSim s))
myThreadId       = (forall r. (ThreadId -> SimA s r) -> SimA s r) -> IOSim s ThreadId
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (ThreadId -> SimA s r) -> SimA s r)
 -> IOSim s ThreadId)
-> (forall r. (ThreadId -> SimA s r) -> SimA s r)
-> IOSim s ThreadId
forall a b. (a -> b) -> a -> b
$ ((ThreadId -> SimA s r) -> SimA s r)
-> (ThreadId -> SimA s r) -> SimA s r
oneShot (((ThreadId -> SimA s r) -> SimA s r)
 -> (ThreadId -> SimA s r) -> SimA s r)
-> ((ThreadId -> SimA s r) -> SimA s r)
-> (ThreadId -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \ThreadId -> SimA s r
k -> (ThreadId -> SimA s r) -> SimA s r
forall s b. (ThreadId -> SimA s b) -> SimA s b
GetThreadId ThreadId -> 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
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 -> ThreadId -> String -> SimA s r -> SimA s r
forall s b. ThreadId -> String -> SimA s b -> SimA s b
LabelThread ThreadId (IOSim s)
ThreadId
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 -> SimA s r) -> SimA s r) -> IOSim s ThreadId
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (ThreadId -> SimA s r) -> SimA s r)
 -> IOSim s ThreadId)
-> (forall r. (ThreadId -> SimA s r) -> SimA s r)
-> IOSim s ThreadId
forall a b. (a -> b) -> a -> b
$ ((ThreadId -> SimA s r) -> SimA s r)
-> (ThreadId -> SimA s r) -> SimA s r
oneShot (((ThreadId -> SimA s r) -> SimA s r)
 -> (ThreadId -> SimA s r) -> SimA s r)
-> ((ThreadId -> SimA s r) -> SimA s r)
-> (ThreadId -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \ThreadId -> SimA s r
k -> IOSim s () -> (ThreadId -> SimA s r) -> SimA s r
forall s b. IOSim s () -> (ThreadId -> SimA s b) -> SimA s b
Fork IOSim s ()
task ThreadId -> 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 forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
unblock)
  throwTo :: 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
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 -> ThreadId -> SimA s r -> SimA s r
forall s a. SomeException -> ThreadId -> SimA s a -> SimA s a
ThrowTo (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e) ThreadId (IOSim s)
ThreadId
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
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
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
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 :: 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 ())
  labelTMVar :: TMVar (IOSim s) a -> String -> STM (IOSim s) ()
labelTMVar   = TMVar (IOSim s) a -> String -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TMVarDefault m a -> String -> STM m ()
MonadSTM.labelTMVarDefault
  labelTQueue :: TQueue (IOSim s) a -> String -> STM (IOSim s) ()
labelTQueue  = TQueue (IOSim s) a -> String -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TQueueDefault m a -> String -> STM m ()
labelTQueueDefault
  labelTBQueue :: TBQueue (IOSim s) a -> String -> STM (IOSim s) ()
labelTBQueue = TBQueue (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)

  atomically :: 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
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 :: 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
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 x s b.
Maybe String -> x -> (TVar s x -> StmA s b) -> StmA s b
NewTVar Maybe String
forall a. Maybe a
Nothing a
x TVar s a -> StmA s r
k
  readTVar :: 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
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 :: 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
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 :: 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
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 :: 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
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 :: a -> STM (IOSim s) (TMVar (IOSim s) a)
newTMVar          = a -> STM (IOSim s) (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TMVarDefault m a)
MonadSTM.newTMVarDefault
  newEmptyTMVar :: STM (IOSim s) (TMVar (IOSim s) a)
newEmptyTMVar     = STM (IOSim s) (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => STM m (TMVarDefault m a)
MonadSTM.newEmptyTMVarDefault
  takeTMVar :: TMVar (IOSim s) a -> STM (IOSim s) a
takeTMVar         = TMVar (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => TMVarDefault m a -> STM m a
MonadSTM.takeTMVarDefault
  tryTakeTMVar :: TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
tryTakeTMVar      = TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m (Maybe a)
MonadSTM.tryTakeTMVarDefault
  putTMVar :: TMVar (IOSim s) a -> a -> STM (IOSim s) ()
putTMVar          = TMVar (IOSim s) a -> a -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m ()
MonadSTM.putTMVarDefault
  tryPutTMVar :: TMVar (IOSim s) a -> a -> STM (IOSim s) Bool
tryPutTMVar       = TMVar (IOSim s) a -> a -> STM (IOSim s) Bool
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m Bool
MonadSTM.tryPutTMVarDefault
  readTMVar :: TMVar (IOSim s) a -> STM (IOSim s) a
readTMVar         = TMVar (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => TMVarDefault m a -> STM m a
MonadSTM.readTMVarDefault
  tryReadTMVar :: TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
tryReadTMVar      = TMVar (IOSim s) a -> STM (IOSim s) (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m (Maybe a)
MonadSTM.tryReadTMVarDefault
  swapTMVar :: TMVar (IOSim s) a -> a -> STM (IOSim s) a
swapTMVar         = TMVar (IOSim s) a -> a -> STM (IOSim s) a
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m a
MonadSTM.swapTMVarDefault
  isEmptyTMVar :: TMVar (IOSim s) a -> STM (IOSim s) Bool
isEmptyTMVar      = TMVar (IOSim s) a -> STM (IOSim s) Bool
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m Bool
MonadSTM.isEmptyTMVarDefault

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

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

  newTMVarIO :: a -> IOSim s (TMVar (IOSim s) a)
newTMVarIO        = a -> IOSim s (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVarDefault m a)
MonadSTM.newTMVarIODefault
  newEmptyTMVarIO :: IOSim s (TMVar (IOSim s) a)
newEmptyTMVarIO   = IOSim s (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => m (TMVarDefault m a)
MonadSTM.newEmptyTMVarIODefault

instance MonadInspectSTM (IOSim s) where
  type InspectMonad (IOSim s) = ST s
  inspectTVar :: proxy (IOSim s) -> TVar (IOSim s) a -> InspectMonad (IOSim s) a
inspectTVar  proxy (IOSim s)
_                 TVar { tvarCurrent }  = STRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef STRef s a
tvarCurrent
  inspectTMVar :: proxy (IOSim s)
-> TMVar (IOSim s) a -> InspectMonad (IOSim s) (Maybe a)
inspectTMVar proxy (IOSim s)
_ (MonadSTM.TMVar TVar { 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 :: 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 ())
  traceTQueue :: 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) ()
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
-> STM m ()
traceTQueueDefault
  traceTBQueue :: 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) ()
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TBQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
-> STM m ()
traceTBQueueDefault

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

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

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

instance Functor (Async s) where
  fmap :: (a -> b) -> Async s a -> Async s b
fmap a -> b
f (Async ThreadId
tid STM s (Either SomeException a)
a) = ThreadId -> STM s (Either SomeException b) -> Async s b
forall s a. ThreadId -> STM s (Either SomeException a) -> Async s a
Async ThreadId
tid ((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 :: 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))
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
MonadSTM.newEmptyTMVarIO
    ThreadId
tid <- ((forall b. IOSim s b -> IOSim s b) -> IOSim s ThreadId)
-> IOSim s ThreadId
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 ThreadId)
 -> IOSim s ThreadId)
-> ((forall b. IOSim s b -> IOSim s b) -> IOSim s ThreadId)
-> IOSim s ThreadId
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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM s () -> IOSim s ()
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 (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
MonadSTM.putTMVar TMVar (IOSim s) (Either SomeException a)
TMVarDefault (IOSim s) (Either SomeException a)
var
    TMVar (IOSim s) (Either SomeException a) -> String -> IOSim s ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TMVar m a -> String -> m ()
MonadSTM.labelTMVarIO TMVar (IOSim s) (Either SomeException a)
TMVarDefault (IOSim s) (Either SomeException a)
var (String
"async-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ThreadId -> String
forall a. Show a => a -> String
show ThreadId
tid)
    Async s a -> IOSim s (Async s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> STM s (Either SomeException a) -> Async s a
forall s a. ThreadId -> STM s (Either SomeException a) -> Async s a
Async ThreadId
tid (TMVar (IOSim s) (Either SomeException a)
-> STM (IOSim s) (Either SomeException a)
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
MonadSTM.readTMVar TMVar (IOSim s) (Either SomeException a)
TMVarDefault (IOSim s) (Either SomeException a)
var))

  asyncThreadId :: Async (IOSim s) a -> ThreadId (IOSim s)
asyncThreadId (Async tid _) = ThreadId (IOSim s)
ThreadId
tid

  waitCatchSTM :: Async (IOSim s) a -> STM (IOSim s) (Either SomeException a)
waitCatchSTM (Async _ w) = STM (IOSim s) (Either SomeException a)
STM s (Either SomeException a)
w
  pollSTM :: Async (IOSim s) a -> STM (IOSim s) (Maybe (Either SomeException a))
pollSTM      (Async _ 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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either SomeException a)
forall a. Maybe a
Nothing

  cancel :: Async (IOSim s) a -> IOSim s ()
cancel a :: Async (IOSim s) a
a@(Async tid _) = ThreadId (IOSim s) -> AsyncCancelled -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
tid AsyncCancelled
AsyncCancelled IOSim s () -> IOSim s (Either SomeException a) -> IOSim s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f 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 :: Async (IOSim s) a -> e -> IOSim s ()
cancelWith a :: Async (IOSim s) a
a@(Async tid _) e
e = ThreadId (IOSim s) -> e -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
tid e
e IOSim s () -> IOSim s (Either SomeException a) -> IOSim s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f 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 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 (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async ((forall b. IOSim s b -> IOSim s b) -> IOSim s a
k forall b. IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
unblock)

instance MonadST (IOSim s) where
  withLiftST :: (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 forall a. ST s a -> IOSim s a
forall s a. ST s a -> IOSim s a
liftST

liftST :: StrictST.ST s a -> IOSim s a
liftST :: 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
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 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
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
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 :: 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
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 :: 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
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 default in terms of MonadTimer

instance MonadTimer (IOSim s) where
  data Timeout (IOSim s) = Timeout !(TVar s TimeoutState) !(TVar s Bool) !TimeoutId
                         -- ^ a timeout; we keep both 'TVar's to support
                         -- `newTimer` and 'registerTimeout'.
                         | NegativeTimeout !TimeoutId
                         -- ^ a negative timeout

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

  newTimeout :: DiffTime -> IOSim s (Timeout (IOSim s))
newTimeout      DiffTime
d = (forall r. (Timeout (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (Timeout (IOSim s))
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Timeout (IOSim s) -> SimA s r) -> SimA s r)
 -> IOSim s (Timeout (IOSim s)))
-> (forall r. (Timeout (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (Timeout (IOSim s))
forall a b. (a -> b) -> a -> b
$ ((Timeout (IOSim s) -> SimA s r) -> SimA s r)
-> (Timeout (IOSim s) -> SimA s r) -> SimA s r
oneShot (((Timeout (IOSim s) -> SimA s r) -> SimA s r)
 -> (Timeout (IOSim s) -> SimA s r) -> SimA s r)
-> ((Timeout (IOSim s) -> SimA s r) -> SimA s r)
-> (Timeout (IOSim s) -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \Timeout (IOSim s) -> SimA s r
k -> DiffTime -> (Timeout (IOSim s) -> SimA s r) -> SimA s r
forall s b. DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
NewTimeout      DiffTime
d Timeout (IOSim s) -> SimA s r
k
  updateTimeout :: Timeout (IOSim s) -> DiffTime -> IOSim s ()
updateTimeout Timeout (IOSim s)
t 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
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 (IOSim s) -> DiffTime -> SimA s r -> SimA s r
forall s b. Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b
UpdateTimeout Timeout (IOSim s)
t DiffTime
d (() -> SimA s r
k ())
  cancelTimeout :: Timeout (IOSim s) -> IOSim s ()
cancelTimeout Timeout (IOSim 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
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 (IOSim s) -> SimA s r -> SimA s r
forall s b. Timeout (IOSim s) -> SimA s b -> SimA s b
CancelTimeout Timeout (IOSim s)
t   (() -> SimA s r
k ())

  timeout :: 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 (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise = do
        ThreadId
pid <- IOSim s ThreadId
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
        t :: Timeout (IOSim s)
t@(Timeout _ _ tid) <- DiffTime -> IOSim s (Timeout (IOSim s))
forall (m :: * -> *). MonadTimer m => DiffTime -> m (Timeout m)
newTimeout DiffTime
d
        (TimeoutException -> Maybe ())
-> (() -> IOSim s (Maybe a))
-> IOSim s (Maybe a)
-> IOSim s (Maybe a)
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust
          (\(TimeoutException TimeoutId
tid') -> if TimeoutId
tid' TimeoutId -> TimeoutId -> Bool
forall a. Eq a => a -> a -> Bool
== TimeoutId
tid
                                         then () -> Maybe ()
forall a. a -> Maybe a
Just ()
                                         else Maybe ()
forall a. Maybe a
Nothing)
          (\()
_ -> Maybe a -> IOSim s (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) (IOSim s (Maybe a) -> IOSim s (Maybe a))
-> IOSim s (Maybe a) -> IOSim s (Maybe a)
forall a b. (a -> b) -> a -> b
$
          IOSim s ThreadId
-> (ThreadId -> IOSim s ())
-> (ThreadId -> IOSim s (Maybe a))
-> IOSim s (Maybe a)
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
            (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
$ do
                String -> IOSim s ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"<<timeout>>"
                Bool
fired <- STM (IOSim s) Bool -> IOSim s Bool
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
MonadSTM.atomically (STM (IOSim s) Bool -> IOSim s Bool)
-> STM (IOSim s) Bool -> IOSim s Bool
forall a b. (a -> b) -> a -> b
$ Timeout (IOSim s) -> STM (IOSim s) Bool
forall (m :: * -> *). MonadTimer m => Timeout m -> STM m Bool
awaitTimeout Timeout (IOSim s)
t
                Bool -> IOSim s () -> IOSim s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fired (IOSim s () -> IOSim s ()) -> IOSim s () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ThreadId (IOSim s) -> TimeoutException -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
pid (TimeoutId -> TimeoutException
TimeoutException TimeoutId
tid))
            (\ThreadId
pid' -> do
                  Timeout (IOSim s) -> IOSim s ()
forall (m :: * -> *). MonadTimer m => Timeout m -> m ()
cancelTimeout Timeout (IOSim s)
t
                  ThreadId (IOSim s) -> AsyncCancelled -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
pid' AsyncCancelled
AsyncCancelled)
            (\ThreadId
_ -> 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)

  registerDelay :: DiffTime -> IOSim s (TVar (IOSim s) Bool)
registerDelay DiffTime
d = (forall r. (TVar s Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar s Bool)
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (TVar s Bool -> SimA s r) -> SimA s r)
 -> IOSim s (TVar s Bool))
-> (forall r. (TVar s Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar s Bool)
forall a b. (a -> b) -> a -> b
$ ((TVar s Bool -> SimA s r) -> SimA s r)
-> (TVar s Bool -> SimA s r) -> SimA s r
oneShot (((TVar s Bool -> SimA s r) -> SimA s r)
 -> (TVar s Bool -> SimA s r) -> SimA s r)
-> ((TVar s Bool -> SimA s r) -> SimA s r)
-> (TVar s Bool -> SimA s r)
-> SimA s r
forall a b. (a -> b) -> a -> b
$ \TVar s Bool -> SimA s r
k -> DiffTime -> (Timeout (IOSim s) -> SimA s r) -> SimA s r
forall s b. DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
NewTimeout DiffTime
d (\(Timeout _var bvar _) -> TVar s Bool -> SimA s r
k TVar s Bool
bvar)

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
/= :: TimeoutException -> TimeoutException -> Bool
$c/= :: TimeoutException -> TimeoutException -> Bool
== :: TimeoutException -> TimeoutException -> Bool
$c== :: TimeoutException -> TimeoutException -> Bool
Eq

instance Show TimeoutException where
    show :: TimeoutException -> String
show TimeoutException
_ = String
"<<timeout>>"

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 sheduling, 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 races discovered.
--
-- See also: 'traceEvents', 'traceResult', 'selectTraceEvents',
-- 'selectTraceEventsDynamic' and 'printTraceEventsSay'.
--
data SimEvent
  = SimEvent {
      SimEvent -> Time
seTime        :: !Time,
      SimEvent -> ThreadId
seThreadId    :: !ThreadId,
      SimEvent -> Maybe String
seThreadLabel :: !(Maybe ThreadLabel),
      SimEvent -> SimEventType
seType        :: !SimEventType
    }
  | SimPOREvent {
      seTime        :: !Time,
      seThreadId    :: !ThreadId,
      SimEvent -> Int
seStep        :: !Int,
      seThreadLabel :: !(Maybe ThreadLabel),
      seType        :: !SimEventType
    }
  | 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
$cto :: forall x. Rep SimEvent x -> SimEvent
$cfrom :: forall x. SimEvent -> Rep SimEvent x
Generic
  deriving Int -> SimEvent -> String -> String
[SimEvent] -> String -> String
SimEvent -> String
(Int -> SimEvent -> String -> String)
-> (SimEvent -> String)
-> ([SimEvent] -> String -> String)
-> Show SimEvent
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SimEvent] -> String -> String
$cshowList :: [SimEvent] -> String -> String
show :: SimEvent -> String
$cshow :: SimEvent -> String
showsPrec :: Int -> SimEvent -> String -> String
$cshowsPrec :: Int -> SimEvent -> String -> String
Show via Quiet SimEvent


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 {Time
seTime :: Time
seTime :: SimEvent -> Time
seTime, ThreadId
seThreadId :: ThreadId
seThreadId :: SimEvent -> ThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel, SimEventType
seType :: SimEventType
seType :: SimEvent -> 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
           (Time -> String
forall a. Show a => a -> String
show Time
seTime)
           Int
tidWidth
           (ThreadId -> String
forall a. Show a => a -> String
show ThreadId
seThreadId)
           Int
tLabelWidth
           String
threadLabel
           (SimEventType -> String
forall a. Show a => a -> String
show 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 {Time
seTime :: Time
seTime :: SimEvent -> Time
seTime, ThreadId
seThreadId :: ThreadId
seThreadId :: SimEvent -> ThreadId
seThreadId, Int
seStep :: Int
seStep :: SimEvent -> Int
seStep, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel, SimEventType
seType :: SimEventType
seType :: SimEvent -> SimEventType
seType} =
    String
-> Int
-> String
-> Int
-> String
-> Int
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%-*s - %-*s %-*s - %s"
           Int
timeWidth
           (Time -> String
forall a. Show a => a -> String
show Time
seTime)
           Int
tidWidth
           ((ThreadId, Int) -> String
forall a. Show a => a -> String
show (ThreadId
seThreadId, Int
seStep))
           Int
tLableWidth
           String
threadLabel
           (SimEventType -> String
forall a. Show a => a -> String
show 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

data SimResult a
    = MainReturn    !Time a             ![Labelled ThreadId]
    | MainException !Time SomeException ![Labelled ThreadId]
    | Deadlock      !Time               ![Labelled ThreadId]
    | Loop
    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
showList :: [SimResult a] -> String -> String
$cshowList :: forall a. Show a => [SimResult a] -> String -> String
show :: SimResult a -> String
$cshow :: forall a. Show a => SimResult a -> String
showsPrec :: Int -> SimResult a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> SimResult a -> String -> String
Show


type SimTrace a = Trace.Trace (SimResult a) SimEvent

-- | Pretty print simulation trace.
--
ppTrace :: Show a => SimTrace a -> String
ppTrace :: 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
               SimResult a -> String
forall a. Show a => a -> String
show
               (Int -> Int -> Int -> SimEvent -> String
ppSimEvent Int
timeWidth Int
tidWith Int
labelWidth)
               SimTrace a
tr
  where
    (Max Int
timeWidth, Max Int
tidWith, 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 (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 :: Time
seTime :: SimEvent -> Time
seTime, ThreadId
seThreadId :: ThreadId
seThreadId :: SimEvent -> ThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length (ThreadId -> String
forall a. Show a => a -> String
show (ThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimPOREvent {Time
seTime :: Time
seTime :: SimEvent -> Time
seTime, ThreadId
seThreadId :: ThreadId
seThreadId :: SimEvent -> ThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length (ThreadId -> String
forall a. Show a => a -> String
show (ThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> 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_ :: 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
tidWith Int
labelWidth)
                SimTrace a
tr
  where
    (Max Int
timeWidth, Max Int
tidWith, 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 (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 :: Time
seTime :: SimEvent -> Time
seTime, ThreadId
seThreadId :: ThreadId
seThreadId :: SimEvent -> ThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length (ThreadId -> String
forall a. Show a => a -> String
show (ThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe String
seThreadLabel)
                  )
                SimPOREvent {Time
seTime :: Time
seTime :: SimEvent -> Time
seTime, ThreadId
seThreadId :: ThreadId
seThreadId :: SimEvent -> ThreadId
seThreadId, Maybe String
seThreadLabel :: Maybe String
seThreadLabel :: SimEvent -> Maybe String
seThreadLabel} ->
                  ( Int -> Max Int
forall a. a -> Max a
Max (String -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length (ThreadId -> String
forall a. Show a => a -> String
show (ThreadId
seThreadId)))
                  , Int -> Max Int
forall a. a -> Max a
Max (Maybe String -> 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 :: 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 (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 Trace :: Time -> ThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a
              -> SimTrace a
pattern $bTrace :: Time
-> ThreadId
-> Maybe String
-> SimEventType
-> SimTrace a
-> SimTrace a
$mTrace :: forall r a.
SimTrace a
-> (Time
    -> ThreadId -> Maybe String -> SimEventType -> SimTrace a -> r)
-> (Void# -> r)
-> r
Trace time threadId threadLabel traceEvent trace =
    Trace.Cons (SimEvent time threadId threadLabel traceEvent)
               trace

{-# DEPRECATED Trace "Use 'SimTrace' instead." #-}

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

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

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

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

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

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

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

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


data SimEventType
  = EventSimStart      ScheduleControl
  | EventSay  String
  | EventLog  Dynamic
  | EventMask MaskingState

  | EventThrow          SomeException
  | EventThrowTo        SomeException ThreadId -- This thread used ThrowTo
  | EventThrowToBlocked                        -- The ThrowTo blocked
  | EventThrowToWakeup                         -- The ThrowTo resumed
  | EventThrowToUnmasked (Labelled ThreadId)   -- A pending ThrowTo was activated

  | EventThreadForked    ThreadId
  | EventThreadFinished                  -- terminated normally
  | EventThreadUnhandled SomeException   -- terminated due to unhandled exception

  | EventTxCommitted   [Labelled TVarId] -- tx wrote to these
                       [Labelled TVarId] -- and created these
                       (Maybe Effect)    -- effect performed (only for `IOSimPOR`)
  | EventTxAborted     (Maybe Effect)    -- effect performed (only for `IOSimPOR`)
  | EventTxBlocked     [Labelled TVarId] -- tx blocked reading these
                       (Maybe Effect)    -- effect performed (only for `IOSimPOR`)
  | EventTxWakeup      [Labelled TVarId] -- changed vars causing retry

  | EventTimerCreated   TimeoutId TVarId Time
  | EventTimerUpdated   TimeoutId        Time
  | EventTimerCancelled TimeoutId
  | EventTimerExpired   TimeoutId

  -- the following events are inserted to mark the difference between
  -- a failed trace and a similar passing trace of the same action
  | EventThreadSleep                      -- the labelling thread was runnable,
                                          -- but its execution was delayed
  | EventThreadWake                       -- until this point
  | EventDeschedule    Deschedule
  | EventFollowControl        ScheduleControl
  | EventAwaitControl  StepId ScheduleControl
  | EventPerformAction StepId
  | EventReschedule           ScheduleControl
  | EventUnblocked     [ThreadId]
  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
showList :: [SimEventType] -> String -> String
$cshowList :: [SimEventType] -> String -> String
show :: SimEventType -> String
$cshow :: SimEventType -> String
showsPrec :: Int -> SimEventType -> String -> String
$cshowsPrec :: Int -> SimEventType -> String -> String
Show

type TraceEvent = SimEventType
{-# DEPRECATED TraceEvent "Use 'SimEventType' instead." #-}

data Labelled a = Labelled {
    Labelled a -> a
l_labelled :: !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
/= :: Labelled a -> Labelled a -> Bool
$c/= :: forall a. Eq a => Labelled a -> Labelled a -> Bool
== :: Labelled a -> Labelled a -> Bool
$c== :: forall a. Eq a => Labelled a -> Labelled a -> Bool
Eq, 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
min :: Labelled a -> Labelled a -> Labelled a
$cmin :: forall a. Ord a => Labelled a -> Labelled a -> Labelled a
max :: Labelled a -> Labelled a -> Labelled a
$cmax :: forall a. Ord a => Labelled a -> Labelled a -> Labelled a
>= :: Labelled a -> Labelled a -> Bool
$c>= :: forall a. Ord a => Labelled a -> Labelled a -> Bool
> :: Labelled a -> Labelled a -> Bool
$c> :: forall a. Ord a => Labelled a -> Labelled a -> Bool
<= :: Labelled a -> Labelled a -> Bool
$c<= :: forall a. Ord a => Labelled a -> Labelled a -> Bool
< :: Labelled a -> Labelled a -> Bool
$c< :: forall a. Ord a => Labelled a -> Labelled a -> Bool
compare :: Labelled a -> Labelled a -> Ordering
$ccompare :: forall a. Ord a => Labelled a -> Labelled a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (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
$cto :: forall a x. Rep (Labelled a) x -> Labelled a
$cfrom :: forall a x. Labelled a -> Rep (Labelled a) x
Generic)
  deriving Int -> Labelled a -> String -> String
[Labelled a] -> String -> String
Labelled a -> String
(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
showList :: [Labelled a] -> String -> String
$cshowList :: forall a. Show a => [Labelled a] -> String -> String
show :: Labelled a -> String
$cshow :: forall a. Show a => Labelled a -> String
showsPrec :: Int -> Labelled a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Labelled a -> String -> String
Show via Quiet (Labelled a)

--
-- Executing STM Transactions
--

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

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 an 'orElse'
  OrElseLeftFrame  :: StmA s a                -- orElse right alternative
                   -> (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

  -- | Executing in the context of the /right/ hand side of an 'orElse'
  OrElseRightFrame :: (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

---
--- Schedules
---

data ScheduleControl = ControlDefault
                     -- ^ default scheduling mode
                     | ControlAwait [ScheduleMod]
                     -- ^ if the current control is 'ControlAwait', the normal
                     -- scheduling will proceed, until the thread found in the
                     -- first 'ScheduleMod' reaches the given step.  At this
                     -- point the thread is put to sleep, until after all the
                     -- steps are followed.
                     | ControlFollow [StepId] [ScheduleMod]
                     -- ^ follow the steps then continue with schedule
                     -- modifications.  This control is set by 'followControl'
                     -- when 'controlTargets' returns true.
  deriving (ScheduleControl -> ScheduleControl -> Bool
(ScheduleControl -> ScheduleControl -> Bool)
-> (ScheduleControl -> ScheduleControl -> Bool)
-> Eq ScheduleControl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScheduleControl -> ScheduleControl -> Bool
$c/= :: ScheduleControl -> ScheduleControl -> Bool
== :: ScheduleControl -> ScheduleControl -> Bool
$c== :: ScheduleControl -> ScheduleControl -> Bool
Eq, Eq ScheduleControl
Eq ScheduleControl
-> (ScheduleControl -> ScheduleControl -> Ordering)
-> (ScheduleControl -> ScheduleControl -> Bool)
-> (ScheduleControl -> ScheduleControl -> Bool)
-> (ScheduleControl -> ScheduleControl -> Bool)
-> (ScheduleControl -> ScheduleControl -> Bool)
-> (ScheduleControl -> ScheduleControl -> ScheduleControl)
-> (ScheduleControl -> ScheduleControl -> ScheduleControl)
-> Ord ScheduleControl
ScheduleControl -> ScheduleControl -> Bool
ScheduleControl -> ScheduleControl -> Ordering
ScheduleControl -> ScheduleControl -> ScheduleControl
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ScheduleControl -> ScheduleControl -> ScheduleControl
$cmin :: ScheduleControl -> ScheduleControl -> ScheduleControl
max :: ScheduleControl -> ScheduleControl -> ScheduleControl
$cmax :: ScheduleControl -> ScheduleControl -> ScheduleControl
>= :: ScheduleControl -> ScheduleControl -> Bool
$c>= :: ScheduleControl -> ScheduleControl -> Bool
> :: ScheduleControl -> ScheduleControl -> Bool
$c> :: ScheduleControl -> ScheduleControl -> Bool
<= :: ScheduleControl -> ScheduleControl -> Bool
$c<= :: ScheduleControl -> ScheduleControl -> Bool
< :: ScheduleControl -> ScheduleControl -> Bool
$c< :: ScheduleControl -> ScheduleControl -> Bool
compare :: ScheduleControl -> ScheduleControl -> Ordering
$ccompare :: ScheduleControl -> ScheduleControl -> Ordering
$cp1Ord :: Eq ScheduleControl
Ord, Int -> ScheduleControl -> String -> String
[ScheduleControl] -> String -> String
ScheduleControl -> String
(Int -> ScheduleControl -> String -> String)
-> (ScheduleControl -> String)
-> ([ScheduleControl] -> String -> String)
-> Show ScheduleControl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ScheduleControl] -> String -> String
$cshowList :: [ScheduleControl] -> String -> String
show :: ScheduleControl -> String
$cshow :: ScheduleControl -> String
showsPrec :: Int -> ScheduleControl -> String -> String
$cshowsPrec :: Int -> ScheduleControl -> String -> String
Show)

data ScheduleMod = ScheduleMod{
    -- | Step at which the 'ScheduleMod' is activated.
    ScheduleMod -> (ThreadId, Int)
scheduleModTarget    :: StepId,
    -- | 'ScheduleControl' at the activation step.  It is needed by
    -- 'extendScheduleControl' when combining the discovered schedule with the
    -- initial one.
    ScheduleMod -> ScheduleControl
scheduleModControl   :: ScheduleControl,
    -- | Series of steps which are executed at the target step.  This *includes*
    -- the target step, not necessarily as the last step.
    ScheduleMod -> [(ThreadId, Int)]
scheduleModInsertion :: [StepId]
  }
  deriving (ScheduleMod -> ScheduleMod -> Bool
(ScheduleMod -> ScheduleMod -> Bool)
-> (ScheduleMod -> ScheduleMod -> Bool) -> Eq ScheduleMod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScheduleMod -> ScheduleMod -> Bool
$c/= :: ScheduleMod -> ScheduleMod -> Bool
== :: ScheduleMod -> ScheduleMod -> Bool
$c== :: ScheduleMod -> ScheduleMod -> Bool
Eq, Eq ScheduleMod
Eq ScheduleMod
-> (ScheduleMod -> ScheduleMod -> Ordering)
-> (ScheduleMod -> ScheduleMod -> Bool)
-> (ScheduleMod -> ScheduleMod -> Bool)
-> (ScheduleMod -> ScheduleMod -> Bool)
-> (ScheduleMod -> ScheduleMod -> Bool)
-> (ScheduleMod -> ScheduleMod -> ScheduleMod)
-> (ScheduleMod -> ScheduleMod -> ScheduleMod)
-> Ord ScheduleMod
ScheduleMod -> ScheduleMod -> Bool
ScheduleMod -> ScheduleMod -> Ordering
ScheduleMod -> ScheduleMod -> ScheduleMod
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ScheduleMod -> ScheduleMod -> ScheduleMod
$cmin :: ScheduleMod -> ScheduleMod -> ScheduleMod
max :: ScheduleMod -> ScheduleMod -> ScheduleMod
$cmax :: ScheduleMod -> ScheduleMod -> ScheduleMod
>= :: ScheduleMod -> ScheduleMod -> Bool
$c>= :: ScheduleMod -> ScheduleMod -> Bool
> :: ScheduleMod -> ScheduleMod -> Bool
$c> :: ScheduleMod -> ScheduleMod -> Bool
<= :: ScheduleMod -> ScheduleMod -> Bool
$c<= :: ScheduleMod -> ScheduleMod -> Bool
< :: ScheduleMod -> ScheduleMod -> Bool
$c< :: ScheduleMod -> ScheduleMod -> Bool
compare :: ScheduleMod -> ScheduleMod -> Ordering
$ccompare :: ScheduleMod -> ScheduleMod -> Ordering
$cp1Ord :: Eq ScheduleMod
Ord)

type StepId = (ThreadId, Int)

instance Show ScheduleMod where
  showsPrec :: Int -> ScheduleMod -> String -> String
showsPrec Int
d (ScheduleMod (ThreadId, Int)
tgt ScheduleControl
ctrl [(ThreadId, Int)]
insertion) =
    Bool -> (String -> String) -> String -> String
showParen (Int
dInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
      String -> String -> String
showString String
"ScheduleMod " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> (ThreadId, Int) -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 (ThreadId, Int)
tgt (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      String -> String -> String
showString String
" " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> ScheduleControl -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 ScheduleControl
ctrl (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      String -> String -> String
showString String
" " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> [(ThreadId, Int)] -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 [(ThreadId, Int)]
insertion

---
--- Exploration options
---

data ExplorationOptions = ExplorationOptions{
    ExplorationOptions -> Int
explorationScheduleBound :: Int,
    ExplorationOptions -> Int
explorationBranching     :: Int,
    ExplorationOptions -> Maybe Int
explorationStepTimelimit :: Maybe Int,
    ExplorationOptions -> Maybe ScheduleControl
explorationReplay        :: Maybe ScheduleControl
  }
  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
showList :: [ExplorationOptions] -> String -> String
$cshowList :: [ExplorationOptions] -> String -> String
show :: ExplorationOptions -> String
$cshow :: ExplorationOptions -> String
showsPrec :: Int -> ExplorationOptions -> String -> String
$cshowsPrec :: Int -> ExplorationOptions -> String -> String
Show

stdExplorationOptions :: ExplorationOptions
stdExplorationOptions :: ExplorationOptions
stdExplorationOptions = ExplorationOptions :: Int
-> Int -> Maybe Int -> Maybe ScheduleControl -> ExplorationOptions
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
    }

type ExplorationSpec = ExplorationOptions -> ExplorationOptions

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

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

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

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