{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-

Implements a scheduler for cooperative multitasking. The scheduler supports
system calls for suspending threads, sending messages to other threads, and
starting new threads. Threads have a priority (see note [Thread Priority]).
They can send and receive messages of a user-defined type. The scheduler is
implemented as handler of the 'Control.Monad.Freer.Coroutine.Yield' effect, and
threads are @freer-simple@ programs that use that effect.

-}
module Plutus.Trace.Scheduler(
    ThreadId
    , SysCall
    , MessageCall(..)
    , ThreadCall(..)
    , WithPriority(..)
    , Priority(..)
    , Tag
    , EmSystemCall
    , AgentSystemCall
    , SuspendedThread
    , EmThread(..)
    , SchedulerState(..)
    -- * Thread API
    , runThreads
    , fork
    , sleep
    , exit
    -- * Etc.
    , mkThread
    , mkSysCall
    , mkAgentSysCall
    , SchedulerLog(..)
    , ThreadEvent(..)
    ) where


import Control.Lens hiding (Empty)
import Control.Monad.Freer
import Control.Monad.Freer.Coroutine
import Control.Monad.Freer.Extras.Log (LogMsg, logDebug)
import Control.Monad.Freer.Reader
import Data.Aeson (FromJSON, ToJSON)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.Hashable (Hashable)
import Data.Map as Map
import Data.Sequence (Seq (..))
import Data.Sequence qualified as Seq
import GHC.Generics (Generic)
import Plutus.Trace.Tag (Tag)
import Prettyprinter
import Prettyprinter.Extras (PrettyShow (..), Tagged (..))

{- Note [Thread Tag]

Within the scheduler, threads are identified by their 'ThreadId'. The thread
ID is assigned at runtime when a new thread is started. So the thread ID
depends on the state of the scheduler at the time the thread is started.

This makes it hard to refer to individual threads outside of the scheduler,
for example, when we inspect the emulator log. To make it easier to find
threads later on in the log, each thread also has a user-defined tag. The
scheduler maintains a map of tags to thread IDs, so that we can send messages
to threads that we only know the tag of.

It is up to the user to ensure that tags are unique. If two threads have the
same tag, the functioning of the scheduler is not affected (each thread still
has its own mailbox), but the tag can no longer be used to uniquely identify a
thread. In practice however the number of interesting threads is small enough
that finding distinct tags for them is not a problem.

-}

-- | Unique identifier of a thread.
newtype ThreadId = ThreadId { ThreadId -> Int
unThreadId :: Int }
    deriving stock (ThreadId -> ThreadId -> Bool
(ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool) -> Eq ThreadId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadId -> ThreadId -> Bool
$c/= :: ThreadId -> ThreadId -> Bool
== :: ThreadId -> ThreadId -> Bool
$c== :: ThreadId -> ThreadId -> Bool
Eq, Eq ThreadId
Eq ThreadId
-> (ThreadId -> ThreadId -> Ordering)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> ThreadId)
-> (ThreadId -> ThreadId -> ThreadId)
-> Ord ThreadId
ThreadId -> ThreadId -> Bool
ThreadId -> ThreadId -> Ordering
ThreadId -> ThreadId -> ThreadId
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 :: ThreadId -> ThreadId -> ThreadId
$cmin :: ThreadId -> ThreadId -> ThreadId
max :: ThreadId -> ThreadId -> ThreadId
$cmax :: ThreadId -> ThreadId -> ThreadId
>= :: ThreadId -> ThreadId -> Bool
$c>= :: ThreadId -> ThreadId -> Bool
> :: ThreadId -> ThreadId -> Bool
$c> :: ThreadId -> ThreadId -> Bool
<= :: ThreadId -> ThreadId -> Bool
$c<= :: ThreadId -> ThreadId -> Bool
< :: ThreadId -> ThreadId -> Bool
$c< :: ThreadId -> ThreadId -> Bool
compare :: ThreadId -> ThreadId -> Ordering
$ccompare :: ThreadId -> ThreadId -> Ordering
$cp1Ord :: Eq ThreadId
Ord, Int -> ThreadId -> ShowS
[ThreadId] -> ShowS
ThreadId -> String
(Int -> ThreadId -> ShowS)
-> (ThreadId -> String) -> ([ThreadId] -> ShowS) -> Show ThreadId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadId] -> ShowS
$cshowList :: [ThreadId] -> ShowS
show :: ThreadId -> String
$cshow :: ThreadId -> String
showsPrec :: Int -> ThreadId -> ShowS
$cshowsPrec :: Int -> ThreadId -> ShowS
Show, (forall x. ThreadId -> Rep ThreadId x)
-> (forall x. Rep ThreadId x -> ThreadId) -> Generic ThreadId
forall x. Rep ThreadId x -> ThreadId
forall x. ThreadId -> Rep ThreadId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ThreadId x -> ThreadId
$cfrom :: forall x. ThreadId -> Rep ThreadId x
Generic)
    deriving anyclass (Int -> ThreadId -> Int
ThreadId -> Int
(Int -> ThreadId -> Int) -> (ThreadId -> Int) -> Hashable ThreadId
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: ThreadId -> Int
$chash :: ThreadId -> Int
hashWithSalt :: Int -> ThreadId -> Int
$chashWithSalt :: Int -> ThreadId -> Int
Hashable, [ThreadId] -> Encoding
[ThreadId] -> Value
ThreadId -> Encoding
ThreadId -> Value
(ThreadId -> Value)
-> (ThreadId -> Encoding)
-> ([ThreadId] -> Value)
-> ([ThreadId] -> Encoding)
-> ToJSON ThreadId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ThreadId] -> Encoding
$ctoEncodingList :: [ThreadId] -> Encoding
toJSONList :: [ThreadId] -> Value
$ctoJSONList :: [ThreadId] -> Value
toEncoding :: ThreadId -> Encoding
$ctoEncoding :: ThreadId -> Encoding
toJSON :: ThreadId -> Value
$ctoJSON :: ThreadId -> Value
ToJSON, Value -> Parser [ThreadId]
Value -> Parser ThreadId
(Value -> Parser ThreadId)
-> (Value -> Parser [ThreadId]) -> FromJSON ThreadId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ThreadId]
$cparseJSONList :: Value -> Parser [ThreadId]
parseJSON :: Value -> Parser ThreadId
$cparseJSON :: Value -> Parser ThreadId
FromJSON)
    deriving [ThreadId] -> Doc ann
ThreadId -> Doc ann
(forall ann. ThreadId -> Doc ann)
-> (forall ann. [ThreadId] -> Doc ann) -> Pretty ThreadId
forall ann. [ThreadId] -> Doc ann
forall ann. ThreadId -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
prettyList :: [ThreadId] -> Doc ann
$cprettyList :: forall ann. [ThreadId] -> Doc ann
pretty :: ThreadId -> Doc ann
$cpretty :: forall ann. ThreadId -> Doc ann
Pretty via (Tagged "Thread" Int)

-- | ID of the first thread.
initialThreadId :: ThreadId
initialThreadId :: ThreadId
initialThreadId = Int -> ThreadId
ThreadId Int
0

{- Note [Thread Priority]

When a thread yields control it assigns itself one of three priorities. The
priority determines how long the thread goes to sleep for. The scheduler
maintains one queue of suspended threads for each priority.

In the emulator, we use thread priorities to drive the progress of simulated
time. See note [Simulator Time] in 'Plutus.Trace.Emulator.System' for details.

-}

{- Note [Freeze and Thaw]

Freezing and unfreezing use two slightly different mechanims.

To freeze a thread, that thread must suspend itself with the 'Frozen' priority.
If we want to be able to freeze a thread from the outside, we need to send it a
message instructing it to do so. (In the emulator, this is the 'Freeze'
constructor of 'Plutus.Trace.Emulator.Types.EmulatorMessage'.)

@
  mkSysCall @_ @EmulatorMessage Normal (Message threadId Freeze)
@


To unfreeze a thread, we use the 'Thaw' system call of the emulator.

@
  mkSysCall @_ @systemEvent Normal (Thaw threadId)
@

Note how the sytem event type in the first line is instantiated to
'EmulatorMessage', and in the second line it is free. The goal of this
somewhat roundabout approach is to avoid having to fish out the thread from the
queues of the scheduler state. Instead, we tell the thread to freeze itself, so
we don't have to mess with the queues.

-}

-- | Priority of a thread.
data Priority =
    Normal -- ^ Thread is ready to run
    | Sleeping -- ^ Thread is sleeping, to be resumed only after an external event happens
    | Frozen -- ^ Thread is frozen, it will only be resumed after it is manually unfrozen via the 'Thaw' sys call.
    deriving stock (Priority -> Priority -> Bool
(Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool) -> Eq Priority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Priority -> Priority -> Bool
$c/= :: Priority -> Priority -> Bool
== :: Priority -> Priority -> Bool
$c== :: Priority -> Priority -> Bool
Eq, Int -> Priority -> ShowS
[Priority] -> ShowS
Priority -> String
(Int -> Priority -> ShowS)
-> (Priority -> String) -> ([Priority] -> ShowS) -> Show Priority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Priority] -> ShowS
$cshowList :: [Priority] -> ShowS
show :: Priority -> String
$cshow :: Priority -> String
showsPrec :: Int -> Priority -> ShowS
$cshowsPrec :: Int -> Priority -> ShowS
Show, (forall x. Priority -> Rep Priority x)
-> (forall x. Rep Priority x -> Priority) -> Generic Priority
forall x. Rep Priority x -> Priority
forall x. Priority -> Rep Priority x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Priority x -> Priority
$cfrom :: forall x. Priority -> Rep Priority x
Generic)
    deriving anyclass ([Priority] -> Encoding
[Priority] -> Value
Priority -> Encoding
Priority -> Value
(Priority -> Value)
-> (Priority -> Encoding)
-> ([Priority] -> Value)
-> ([Priority] -> Encoding)
-> ToJSON Priority
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Priority] -> Encoding
$ctoEncodingList :: [Priority] -> Encoding
toJSONList :: [Priority] -> Value
$ctoJSONList :: [Priority] -> Value
toEncoding :: Priority -> Encoding
$ctoEncoding :: Priority -> Encoding
toJSON :: Priority -> Value
$ctoJSON :: Priority -> Value
ToJSON, Value -> Parser [Priority]
Value -> Parser Priority
(Value -> Parser Priority)
-> (Value -> Parser [Priority]) -> FromJSON Priority
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Priority]
$cparseJSONList :: Value -> Parser [Priority]
parseJSON :: Value -> Parser Priority
$cparseJSON :: Value -> Parser Priority
FromJSON)
    deriving [Priority] -> Doc ann
Priority -> Doc ann
(forall ann. Priority -> Doc ann)
-> (forall ann. [Priority] -> Doc ann) -> Pretty Priority
forall ann. [Priority] -> Doc ann
forall ann. Priority -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
prettyList :: [Priority] -> Doc ann
$cprettyList :: forall ann. [Priority] -> Doc ann
pretty :: Priority -> Doc ann
$cpretty :: forall ann. Priority -> Doc ann
Pretty via (PrettyShow Priority)

-- | A thread with a 'Priority'.
data WithPriority t
    = WithPriority
        { WithPriority t -> Priority
_priority :: Priority
        , WithPriority t -> t
_thread   :: t
        } deriving a -> WithPriority b -> WithPriority a
(a -> b) -> WithPriority a -> WithPriority b
(forall a b. (a -> b) -> WithPriority a -> WithPriority b)
-> (forall a b. a -> WithPriority b -> WithPriority a)
-> Functor WithPriority
forall a b. a -> WithPriority b -> WithPriority a
forall a b. (a -> b) -> WithPriority a -> WithPriority b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> WithPriority b -> WithPriority a
$c<$ :: forall a b. a -> WithPriority b -> WithPriority a
fmap :: (a -> b) -> WithPriority a -> WithPriority b
$cfmap :: forall a b. (a -> b) -> WithPriority a -> WithPriority b
Functor

type SuspendedThread effs systemEvent a = WithPriority (EmThread effs systemEvent a)

type EmSystemCall effs systemEvent a = WithPriority (SysCall effs systemEvent a)

type AgentSystemCall systemEvent = WithPriority (MessageCall systemEvent)

-- | Thread that can be run by the scheduler
data EmThread effs systemEvent a =
    EmThread
        { EmThread effs systemEvent a
-> Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation :: Maybe systemEvent -> Eff effs (Status effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()) -- ^ The continuation to be run when the thread is resumed.
        , EmThread effs systemEvent a -> ThreadId
_threadId     :: ThreadId -- ^ Thread ID
        , EmThread effs systemEvent a -> Tag
_tag          :: Tag -- ^ Tag of the thread. See note [Thread Tag]
        }

-- | The system calls we can make to the scheduler, affecting the the threads
--   that are currently running.
data ThreadCall effs systemEvent a
    = Fork (ThreadId -> SuspendedThread effs systemEvent a) -- ^ Start a new thread with a new thread ID.
    | Thaw ThreadId -- ^ Unfreeze a thread.
    | Exit a -- ^ Terminate the scheduler.

-- | Sending messages to other threads and waiting for new messages to arrive.
data MessageCall systemEvent
    = WaitForMessage -- ^ Suspend ourselves (the caller) until we receive a message
    | Broadcast systemEvent -- ^ Send a message to all threads
    | Message ThreadId systemEvent -- ^ Send a message to a specific thread

type SysCall effs systemEvent a = Either (MessageCall systemEvent) (ThreadCall effs systemEvent a)

makePrisms ''MessageCall
makePrisms ''ThreadCall

-- | Scheduler state
data SchedulerState effs systemEvent a
    = SchedulerState
        { SchedulerState effs systemEvent a
-> Seq (EmThread effs systemEvent a)
_normalPrio    :: Seq (EmThread effs systemEvent a) -- ^  Threads running at normal priority
        , SchedulerState effs systemEvent a
-> Seq (EmThread effs systemEvent a)
_sleeping      :: Seq (EmThread effs systemEvent a) -- ^ Sleeping threads (waiting for an external event)
        , SchedulerState effs systemEvent a
-> Seq (EmThread effs systemEvent a)
_frozen        :: Seq (EmThread effs systemEvent a) -- ^ Frozen threads (will not be resumed until they are explicitly unfrozen)
        , SchedulerState effs systemEvent a -> ThreadId
_lastThreadId  :: ThreadId -- ^ Last thread id assigned to a thread
        , SchedulerState effs systemEvent a
-> HashMap ThreadId (Seq systemEvent)
_mailboxes     :: HashMap ThreadId (Seq systemEvent) -- ^ The mailboxes of all active threads.
        , SchedulerState effs systemEvent a -> Map Tag (HashSet ThreadId)
_activeThreads :: Map Tag (HashSet ThreadId) -- ^ Map of tags to thread IDs. See note [Thread Tag]
        }

makeLenses ''SchedulerState

-- | Remove a thread from the set of active threads. Usually called when the
--   thread is finished.
removeActiveThread :: ThreadId -> SchedulerState effs systemEvent a -> SchedulerState effs systemEvent a
removeActiveThread :: ThreadId
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
removeActiveThread ThreadId
tid = ASetter
  (SchedulerState effs systemEvent a)
  (SchedulerState effs systemEvent a)
  (HashSet ThreadId)
  (HashSet ThreadId)
-> (HashSet ThreadId -> HashSet ThreadId)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Map Tag (HashSet ThreadId)
 -> Identity (Map Tag (HashSet ThreadId)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a) (Map Tag (HashSet ThreadId))
activeThreads ((Map Tag (HashSet ThreadId)
  -> Identity (Map Tag (HashSet ThreadId)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((HashSet ThreadId -> Identity (HashSet ThreadId))
    -> Map Tag (HashSet ThreadId)
    -> Identity (Map Tag (HashSet ThreadId)))
-> ASetter
     (SchedulerState effs systemEvent a)
     (SchedulerState effs systemEvent a)
     (HashSet ThreadId)
     (HashSet ThreadId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashSet ThreadId -> Identity (HashSet ThreadId))
-> Map Tag (HashSet ThreadId)
-> Identity (Map Tag (HashSet ThreadId))
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) (ThreadId -> HashSet ThreadId -> HashSet ThreadId
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete ThreadId
tid)

-- | A suspended thread with a priority and the thread itself.
suspendThread :: Priority -> EmThread effs systemEvent a -> SuspendedThread effs systemEvent a
suspendThread :: Priority
-> EmThread effs systemEvent a
-> SuspendedThread effs systemEvent a
suspendThread = Priority
-> EmThread effs systemEvent a
-> SuspendedThread effs systemEvent a
forall t. Priority -> t -> WithPriority t
WithPriority

-- | Make a thread with the given priority from an action. This is a
--   convenience for defining 'SimulatorInterpreter' values.
mkThread :: Tag -> Priority -> Eff (Reader ThreadId ': Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent) ': effs) () -> ThreadId -> SuspendedThread effs systemEvent a
mkThread :: Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> ThreadId
-> SuspendedThread effs systemEvent a
mkThread Tag
tag Priority
prio Eff
  (Reader ThreadId
     : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
action ThreadId
tid =
    let action' :: Eff
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
action' = ThreadId
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff
     (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
forall r (effs :: [* -> *]) a.
r -> Eff (Reader r : effs) a -> Eff effs a
runReader ThreadId
tid Eff
  (Reader ThreadId
     : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
action
    in WithPriority :: forall t. Priority -> t -> WithPriority t
WithPriority
            { _priority :: Priority
_priority = Priority
prio
            , _thread :: EmThread effs systemEvent a
_thread = EmThread :: forall (effs :: [* -> *]) systemEvent a.
(Maybe systemEvent
 -> Eff
      effs
      (Status
         effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()))
-> ThreadId -> Tag -> EmThread effs systemEvent a
EmThread
                { _threadId :: ThreadId
_threadId = ThreadId
tid
                , _continuation :: Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation = \Maybe systemEvent
_ -> Eff
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
forall a b (effs :: [* -> *]) r.
Eff (Yield a b : effs) r -> Eff effs (Status effs a b r)
runC Eff
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
action'
                , _tag :: Tag
_tag      = Tag
tag
                }
            }

-- | Make a 'MessageCall' system call for some agent
mkAgentSysCall :: forall effs systemEvent.
    Member (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs
    => Priority -- ^ The 'Priority' of the caller
    -> MessageCall systemEvent -- ^ The system call
    -> Eff effs (Maybe systemEvent)
mkAgentSysCall :: Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall Priority
prio MessageCall systemEvent
sc = AgentSystemCall systemEvent
-> (Maybe systemEvent -> Maybe systemEvent)
-> Eff effs (Maybe systemEvent)
forall a b (effs :: [* -> *]) c.
Member (Yield a b) effs =>
a -> (b -> c) -> Eff effs c
yield @(AgentSystemCall systemEvent) @(Maybe systemEvent) (Priority -> MessageCall systemEvent -> AgentSystemCall systemEvent
forall t. Priority -> t -> WithPriority t
WithPriority Priority
prio MessageCall systemEvent
sc) Maybe systemEvent -> Maybe systemEvent
forall a. a -> a
id

-- | Make a system call
mkSysCall :: forall effs systemEvent effs2 a.
    Member (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)) effs2
    => Priority -- ^ The 'Priority' of the caller
    -> SysCall effs systemEvent a -- ^ The system call
    -> Eff effs2 (Maybe systemEvent)
mkSysCall :: Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall Priority
prio SysCall effs systemEvent a
sc = EmSystemCall effs systemEvent a
-> (Maybe systemEvent -> Maybe systemEvent)
-> Eff effs2 (Maybe systemEvent)
forall a b (effs :: [* -> *]) c.
Member (Yield a b) effs =>
a -> (b -> c) -> Eff effs c
yield @(EmSystemCall effs systemEvent a) @(Maybe systemEvent) (Priority
-> SysCall effs systemEvent a -> EmSystemCall effs systemEvent a
forall t. Priority -> t -> WithPriority t
WithPriority Priority
prio SysCall effs systemEvent a
sc) Maybe systemEvent -> Maybe systemEvent
forall a. a -> a
id

-- | Start a new thread
fork :: forall effs systemEvent effs2 a.
    Member (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)) effs2
    => Tag -- ^ Tag of the new thread. See note [Thread Tag]
    -> Priority -- ^ Priority of the new thread.
    -> Eff (Reader ThreadId ': Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent) ': effs) ()
    -> Eff effs2 (Maybe systemEvent)
fork :: Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff effs2 (Maybe systemEvent)
fork Tag
tag Priority
prio Eff
  (Reader ThreadId
     : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
action = Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall Priority
prio (ThreadCall effs systemEvent a -> SysCall effs systemEvent a
forall a b. b -> Either a b
Right (ThreadCall effs systemEvent a -> SysCall effs systemEvent a)
-> ThreadCall effs systemEvent a -> SysCall effs systemEvent a
forall a b. (a -> b) -> a -> b
$ (ThreadId -> SuspendedThread effs systemEvent a)
-> ThreadCall effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
(ThreadId -> SuspendedThread effs systemEvent a)
-> ThreadCall effs systemEvent a
Fork ((ThreadId -> SuspendedThread effs systemEvent a)
 -> ThreadCall effs systemEvent a)
-> (ThreadId -> SuspendedThread effs systemEvent a)
-> ThreadCall effs systemEvent a
forall a b. (a -> b) -> a -> b
$ Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> ThreadId
-> SuspendedThread effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> ThreadId
-> SuspendedThread effs systemEvent a
mkThread Tag
tag Priority
prio Eff
  (Reader ThreadId
     : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
action)

-- | Suspend the current thread
sleep :: forall effs systemEvent effs2 a.
    Member (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)) effs2
    => Priority
    -> Eff effs2 (Maybe systemEvent)
sleep :: Priority -> Eff effs2 (Maybe systemEvent)
sleep Priority
prio = Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall @effs @systemEvent @effs2 @a Priority
prio (MessageCall systemEvent -> SysCall effs systemEvent a
forall a b. a -> Either a b
Left MessageCall systemEvent
forall systemEvent. MessageCall systemEvent
WaitForMessage)

-- | Stop the scheduler and let it return with the given value.
exit :: forall effs systemEvent effs2 a.
    Member (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)) effs2
    => a -> Eff effs2 (Maybe systemEvent)
exit :: a -> Eff effs2 (Maybe systemEvent)
exit a
a = Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall @effs @systemEvent @effs2 Priority
Normal (ThreadCall effs systemEvent a -> SysCall effs systemEvent a
forall a b. b -> Either a b
Right (a -> ThreadCall effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
a -> ThreadCall effs systemEvent a
Exit a
a))

-- | Tag of the initial thread.
initialThreadTag :: Tag
initialThreadTag :: Tag
initialThreadTag = Tag
"initial thread"

-- | Handle the 'Yield (EmSystemCall effs systemEvent) (Maybe systemEvent)'
--   effect using the scheduler, see note [Scheduler]. 'runThreads' only
--   returns when all threads are finished, returning `Nothing`, or when
--   `exit` is called, in which case the value passed to `exit` is returned.
runThreads ::
    forall a effs systemEvent.
    ( Eq systemEvent
    , Member (LogMsg SchedulerLog) effs
    )
    => Eff (Reader ThreadId ': Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent) ': effs) ()
    -> Eff effs (Maybe a)
runThreads :: Eff
  (Reader ThreadId
     : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
-> Eff effs (Maybe a)
runThreads Eff
  (Reader ThreadId
     : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
e = do
    Status
  effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()
k <- Eff
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
forall a b (effs :: [* -> *]) r.
Eff (Yield a b : effs) r -> Eff effs (Status effs a b r)
runC (Eff
   (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
      : effs)
   ()
 -> Eff
      effs
      (Status
         effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()))
-> Eff
     (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
forall a b. (a -> b) -> a -> b
$ ThreadId
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff
     (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
forall r (effs :: [* -> *]) a.
r -> Eff (Reader r : effs) a -> Eff effs a
runReader ThreadId
initialThreadId Eff
  (Reader ThreadId
     : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
     : effs)
  ()
e
    case Status
  effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()
k of
        Done () -> Maybe a -> Eff effs (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        Continue EmSystemCall effs systemEvent a
_ Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
k' ->
            let initialThread :: EmThread effs systemEvent a
initialThread = EmThread :: forall (effs :: [* -> *]) systemEvent a.
(Maybe systemEvent
 -> Eff
      effs
      (Status
         effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()))
-> ThreadId -> Tag -> EmThread effs systemEvent a
EmThread{_continuation :: Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation = Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
k', _threadId :: ThreadId
_threadId = ThreadId
initialThreadId, _tag :: Tag
_tag = Tag
initialThreadTag}
            in SchedulerState effs systemEvent a -> Eff effs (Maybe a)
forall a (effs :: [* -> *]) systemEvent.
(Eq systemEvent, Member (LogMsg SchedulerLog) effs) =>
SchedulerState effs systemEvent a -> Eff effs (Maybe a)
loop
                (SchedulerState effs systemEvent a -> Eff effs (Maybe a))
-> SchedulerState effs systemEvent a -> Eff effs (Maybe a)
forall a b. (a -> b) -> a -> b
$ SchedulerState effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
SchedulerState effs systemEvent a
initialState
                    SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Map Tag (HashSet ThreadId)
 -> Identity (Map Tag (HashSet ThreadId)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a) (Map Tag (HashSet ThreadId))
activeThreads ((Map Tag (HashSet ThreadId)
  -> Identity (Map Tag (HashSet ThreadId)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((HashSet ThreadId -> Identity (HashSet ThreadId))
    -> Map Tag (HashSet ThreadId)
    -> Identity (Map Tag (HashSet ThreadId)))
-> (HashSet ThreadId -> Identity (HashSet ThreadId))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Tag (HashSet ThreadId))
-> Lens'
     (Map Tag (HashSet ThreadId))
     (Maybe (IxValue (Map Tag (HashSet ThreadId))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Tag (HashSet ThreadId))
Tag
initialThreadTag ((Maybe (HashSet ThreadId) -> Identity (Maybe (HashSet ThreadId)))
 -> Map Tag (HashSet ThreadId)
 -> Identity (Map Tag (HashSet ThreadId)))
-> ((HashSet ThreadId -> Identity (HashSet ThreadId))
    -> Maybe (HashSet ThreadId) -> Identity (Maybe (HashSet ThreadId)))
-> (HashSet ThreadId -> Identity (HashSet ThreadId))
-> Map Tag (HashSet ThreadId)
-> Identity (Map Tag (HashSet ThreadId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet ThreadId
-> Iso' (Maybe (HashSet ThreadId)) (HashSet ThreadId)
forall a. Eq a => a -> Iso' (Maybe a) a
non HashSet ThreadId
forall a. Monoid a => a
mempty ((HashSet ThreadId -> Identity (HashSet ThreadId))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (HashSet ThreadId -> HashSet ThreadId)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ThreadId -> HashSet ThreadId -> HashSet ThreadId
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert ThreadId
initialThreadId
                    SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (HashMap ThreadId (Seq systemEvent)
 -> Identity (HashMap ThreadId (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (HashMap ThreadId (Seq systemEvent))
mailboxes ((HashMap ThreadId (Seq systemEvent)
  -> Identity (HashMap ThreadId (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
    -> HashMap ThreadId (Seq systemEvent)
    -> Identity (HashMap ThreadId (Seq systemEvent)))
-> (Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap ThreadId (Seq systemEvent))
-> Lens'
     (HashMap ThreadId (Seq systemEvent))
     (Maybe (IxValue (HashMap ThreadId (Seq systemEvent))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap ThreadId (Seq systemEvent))
ThreadId
initialThreadId ((Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> Seq systemEvent
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Seq systemEvent
forall a. Seq a
Seq.empty
                    SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& ((SchedulerState effs systemEvent a, ThreadId)
-> SchedulerState effs systemEvent a
forall a b. (a, b) -> a
fst ((SchedulerState effs systemEvent a, ThreadId)
 -> SchedulerState effs systemEvent a)
-> (SchedulerState effs systemEvent a
    -> (SchedulerState effs systemEvent a, ThreadId))
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a, ThreadId)
forall (effs :: [* -> *]) systemEvent a.
SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a, ThreadId)
nextThreadId)
                    SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& SuspendedThread effs systemEvent a
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
SuspendedThread effs systemEvent a
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
enqueue (Priority
-> EmThread effs systemEvent a
-> SuspendedThread effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
Priority
-> EmThread effs systemEvent a
-> SuspendedThread effs systemEvent a
suspendThread Priority
Normal EmThread effs systemEvent a
initialThread)

-- | Run the threads that are scheduled in a 'SchedulerState' to completion.
loop :: forall a effs systemEvent.
    ( Eq systemEvent
    , Member (LogMsg SchedulerLog) effs
    )
    => SchedulerState effs systemEvent a
    -> Eff effs (Maybe a)
loop :: SchedulerState effs systemEvent a -> Eff effs (Maybe a)
loop SchedulerState effs systemEvent a
s = do
    case SchedulerState effs systemEvent a
-> SchedulerDQResult effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
SchedulerState effs systemEvent a
-> SchedulerDQResult effs systemEvent a
dequeue SchedulerState effs systemEvent a
s of
        AThread EmThread{Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation :: Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation :: forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a
-> Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation, ThreadId
_threadId :: ThreadId
_threadId :: forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a -> ThreadId
_threadId, Tag
_tag :: Tag
_tag :: forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a -> Tag
_tag} Maybe systemEvent
event SchedulerState effs systemEvent a
schedulerState Priority
prio -> do
            let mkLog :: ThreadEvent -> SchedulerLog
mkLog ThreadEvent
e = SchedulerLog :: ThreadEvent -> ThreadId -> Tag -> Priority -> SchedulerLog
SchedulerLog{slEvent :: ThreadEvent
slEvent=ThreadEvent
e, slThread :: ThreadId
slThread=ThreadId
_threadId, slPrio :: Priority
slPrio=Priority
prio, slTag :: Tag
slTag = Tag
_tag}
            Status
  effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()
result <- Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation Maybe systemEvent
event
            case Status
  effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()
result of
                Done ()
_ -> SchedulerState effs systemEvent a -> Eff effs (Maybe a)
forall a (effs :: [* -> *]) systemEvent.
(Eq systemEvent, Member (LogMsg SchedulerLog) effs) =>
SchedulerState effs systemEvent a -> Eff effs (Maybe a)
loop (SchedulerState effs systemEvent a -> Eff effs (Maybe a))
-> SchedulerState effs systemEvent a -> Eff effs (Maybe a)
forall a b. (a -> b) -> a -> b
$ SchedulerState effs systemEvent a
schedulerState SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& ThreadId
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
ThreadId
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
removeActiveThread ThreadId
_threadId
                Continue WithPriority{Priority
_priority :: Priority
_priority :: forall t. WithPriority t -> Priority
_priority, _thread :: forall t. WithPriority t -> t
_thread=SysCall effs systemEvent a
sysCall} Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
k -> do
                    let thisThread :: SuspendedThread effs systemEvent a
thisThread = Priority
-> EmThread effs systemEvent a
-> SuspendedThread effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
Priority
-> EmThread effs systemEvent a
-> SuspendedThread effs systemEvent a
suspendThread Priority
_priority EmThread :: forall (effs :: [* -> *]) systemEvent a.
(Maybe systemEvent
 -> Eff
      effs
      (Status
         effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ()))
-> ThreadId -> Tag -> EmThread effs systemEvent a
EmThread{_threadId :: ThreadId
_threadId=ThreadId
_threadId, _continuation :: Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
_continuation=Maybe systemEvent
-> Eff
     effs
     (Status
        effs (EmSystemCall effs systemEvent a) (Maybe systemEvent) ())
k, _tag :: Tag
_tag = Tag
_tag}
                    Either a (SchedulerState effs systemEvent a)
newState <- SchedulerState effs systemEvent a
schedulerState SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& SuspendedThread effs systemEvent a
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
SuspendedThread effs systemEvent a
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
enqueue SuspendedThread effs systemEvent a
thisThread SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> Eff effs (Either a (SchedulerState effs systemEvent a)))
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall a b. a -> (a -> b) -> b
& SysCall effs systemEvent a
-> SchedulerState effs systemEvent a
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall systemEvent (effs :: [* -> *]) a.
(Eq systemEvent, Member (LogMsg SchedulerLog) effs) =>
SysCall effs systemEvent a
-> SchedulerState effs systemEvent a
-> Eff effs (Either a (SchedulerState effs systemEvent a))
handleSysCall SysCall effs systemEvent a
sysCall
                    case Either a (SchedulerState effs systemEvent a)
newState of
                        Left a
a          -> SchedulerLog -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (ThreadEvent -> SchedulerLog
mkLog ThreadEvent
Stopped) Eff effs () -> Eff effs (Maybe a) -> Eff effs (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> Eff effs (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
                        Right SchedulerState effs systemEvent a
newState' -> SchedulerState effs systemEvent a -> Eff effs (Maybe a)
forall a (effs :: [* -> *]) systemEvent.
(Eq systemEvent, Member (LogMsg SchedulerLog) effs) =>
SchedulerState effs systemEvent a -> Eff effs (Maybe a)
loop SchedulerState effs systemEvent a
newState'
        SchedulerDQResult effs systemEvent a
_ -> Maybe a -> Eff effs (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | Deal with a system call from a running thread.
handleSysCall ::
    ( Eq systemEvent
    , Member (LogMsg SchedulerLog) effs
    )
    => SysCall effs systemEvent a
    -> SchedulerState effs systemEvent a
    -> Eff effs (Either a (SchedulerState effs systemEvent a))
handleSysCall :: SysCall effs systemEvent a
-> SchedulerState effs systemEvent a
-> Eff effs (Either a (SchedulerState effs systemEvent a))
handleSysCall SysCall effs systemEvent a
sysCall SchedulerState effs systemEvent a
schedulerState = case SysCall effs systemEvent a
sysCall of
    Right (Fork ThreadId -> SuspendedThread effs systemEvent a
newThread) -> do
        let (SchedulerState effs systemEvent a
schedulerState', ThreadId
tid) = SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a, ThreadId)
forall (effs :: [* -> *]) systemEvent a.
SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a, ThreadId)
nextThreadId SchedulerState effs systemEvent a
schedulerState
            t :: SuspendedThread effs systemEvent a
t = ThreadId -> SuspendedThread effs systemEvent a
newThread ThreadId
tid
            tag :: Tag
tag = EmThread effs systemEvent a -> Tag
forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a -> Tag
_tag (EmThread effs systemEvent a -> Tag)
-> EmThread effs systemEvent a -> Tag
forall a b. (a -> b) -> a -> b
$ SuspendedThread effs systemEvent a -> EmThread effs systemEvent a
forall t. WithPriority t -> t
_thread SuspendedThread effs systemEvent a
t
            newState :: SchedulerState effs systemEvent a
newState = SuspendedThread effs systemEvent a
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
SuspendedThread effs systemEvent a
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
enqueue SuspendedThread effs systemEvent a
t SchedulerState effs systemEvent a
schedulerState'
                        SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Map Tag (HashSet ThreadId)
 -> Identity (Map Tag (HashSet ThreadId)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a) (Map Tag (HashSet ThreadId))
activeThreads ((Map Tag (HashSet ThreadId)
  -> Identity (Map Tag (HashSet ThreadId)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((HashSet ThreadId -> Identity (HashSet ThreadId))
    -> Map Tag (HashSet ThreadId)
    -> Identity (Map Tag (HashSet ThreadId)))
-> (HashSet ThreadId -> Identity (HashSet ThreadId))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Tag (HashSet ThreadId))
-> Lens'
     (Map Tag (HashSet ThreadId))
     (Maybe (IxValue (Map Tag (HashSet ThreadId))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Tag (HashSet ThreadId))
Tag
tag ((Maybe (HashSet ThreadId) -> Identity (Maybe (HashSet ThreadId)))
 -> Map Tag (HashSet ThreadId)
 -> Identity (Map Tag (HashSet ThreadId)))
-> ((HashSet ThreadId -> Identity (HashSet ThreadId))
    -> Maybe (HashSet ThreadId) -> Identity (Maybe (HashSet ThreadId)))
-> (HashSet ThreadId -> Identity (HashSet ThreadId))
-> Map Tag (HashSet ThreadId)
-> Identity (Map Tag (HashSet ThreadId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet ThreadId
-> Iso' (Maybe (HashSet ThreadId)) (HashSet ThreadId)
forall a. Eq a => a -> Iso' (Maybe a) a
non HashSet ThreadId
forall a. Monoid a => a
mempty ((HashSet ThreadId -> Identity (HashSet ThreadId))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (HashSet ThreadId -> HashSet ThreadId)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ThreadId -> HashSet ThreadId -> HashSet ThreadId
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert ThreadId
tid
                        SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (HashMap ThreadId (Seq systemEvent)
 -> Identity (HashMap ThreadId (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (HashMap ThreadId (Seq systemEvent))
mailboxes ((HashMap ThreadId (Seq systemEvent)
  -> Identity (HashMap ThreadId (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
    -> HashMap ThreadId (Seq systemEvent)
    -> Identity (HashMap ThreadId (Seq systemEvent)))
-> (Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap ThreadId (Seq systemEvent))
-> Lens'
     (HashMap ThreadId (Seq systemEvent))
     (Maybe (IxValue (HashMap ThreadId (Seq systemEvent))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap ThreadId (Seq systemEvent))
ThreadId
tid ((Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> Maybe (Seq systemEvent)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq systemEvent -> Maybe (Seq systemEvent)
forall a. a -> Maybe a
Just Seq systemEvent
forall a. Seq a
Seq.empty
        SchedulerLog -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (SchedulerLog -> Eff effs ()) -> SchedulerLog -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ SchedulerLog :: ThreadEvent -> ThreadId -> Tag -> Priority -> SchedulerLog
SchedulerLog{slEvent :: ThreadEvent
slEvent = ThreadEvent
Started, slThread :: ThreadId
slThread = ThreadId
tid, slPrio :: Priority
slPrio = SuspendedThread effs systemEvent a -> Priority
forall t. WithPriority t -> Priority
_priority SuspendedThread effs systemEvent a
t, slTag :: Tag
slTag = Tag
tag}
        Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. b -> Either a b
Right SchedulerState effs systemEvent a
newState)
    Left MessageCall systemEvent
WaitForMessage -> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (SchedulerState effs systemEvent a)
 -> Eff effs (Either a (SchedulerState effs systemEvent a)))
-> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall a b. (a -> b) -> a -> b
$ SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. b -> Either a b
Right SchedulerState effs systemEvent a
schedulerState
    Left (Broadcast systemEvent
msg) -> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (SchedulerState effs systemEvent a)
 -> Eff effs (Either a (SchedulerState effs systemEvent a)))
-> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall a b. (a -> b) -> a -> b
$ SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. b -> Either a b
Right (SchedulerState effs systemEvent a
 -> Either a (SchedulerState effs systemEvent a))
-> SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. (a -> b) -> a -> b
$ SchedulerState effs systemEvent a
schedulerState SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (HashMap ThreadId (Seq systemEvent)
 -> Identity (HashMap ThreadId (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (HashMap ThreadId (Seq systemEvent))
mailboxes ((HashMap ThreadId (Seq systemEvent)
  -> Identity (HashMap ThreadId (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((Seq systemEvent -> Identity (Seq systemEvent))
    -> HashMap ThreadId (Seq systemEvent)
    -> Identity (HashMap ThreadId (Seq systemEvent)))
-> (Seq systemEvent -> Identity (Seq systemEvent))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq systemEvent -> Identity (Seq systemEvent))
-> HashMap ThreadId (Seq systemEvent)
-> Identity (HashMap ThreadId (Seq systemEvent))
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed ((Seq systemEvent -> Identity (Seq systemEvent))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (Seq systemEvent -> Seq systemEvent)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq systemEvent -> systemEvent -> Seq systemEvent
forall s a. Snoc s s a a => s -> a -> s
|> systemEvent
msg)
    Left (Message ThreadId
t systemEvent
msg) -> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (SchedulerState effs systemEvent a)
 -> Eff effs (Either a (SchedulerState effs systemEvent a)))
-> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall a b. (a -> b) -> a -> b
$ SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. b -> Either a b
Right (SchedulerState effs systemEvent a
 -> Either a (SchedulerState effs systemEvent a))
-> SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. (a -> b) -> a -> b
$ SchedulerState effs systemEvent a
schedulerState SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (HashMap ThreadId (Seq systemEvent)
 -> Identity (HashMap ThreadId (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (HashMap ThreadId (Seq systemEvent))
mailboxes ((HashMap ThreadId (Seq systemEvent)
  -> Identity (HashMap ThreadId (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((Seq systemEvent -> Identity (Seq systemEvent))
    -> HashMap ThreadId (Seq systemEvent)
    -> Identity (HashMap ThreadId (Seq systemEvent)))
-> (Seq systemEvent -> Identity (Seq systemEvent))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap ThreadId (Seq systemEvent))
-> Lens'
     (HashMap ThreadId (Seq systemEvent))
     (Maybe (IxValue (HashMap ThreadId (Seq systemEvent))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap ThreadId (Seq systemEvent))
ThreadId
t ((Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
 -> HashMap ThreadId (Seq systemEvent)
 -> Identity (HashMap ThreadId (Seq systemEvent)))
-> ((Seq systemEvent -> Identity (Seq systemEvent))
    -> Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
-> (Seq systemEvent -> Identity (Seq systemEvent))
-> HashMap ThreadId (Seq systemEvent)
-> Identity (HashMap ThreadId (Seq systemEvent))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq systemEvent -> Iso' (Maybe (Seq systemEvent)) (Seq systemEvent)
forall a. Eq a => a -> Iso' (Maybe a) a
non Seq systemEvent
forall a. Monoid a => a
mempty ((Seq systemEvent -> Identity (Seq systemEvent))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (Seq systemEvent -> Seq systemEvent)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq systemEvent -> systemEvent -> Seq systemEvent
forall s a. Snoc s s a a => s -> a -> s
|> systemEvent
msg)
    Right (Thaw ThreadId
tid) -> do
        let (Seq (EmThread effs systemEvent a)
thawed, Seq (EmThread effs systemEvent a)
rest) = (EmThread effs systemEvent a -> Bool)
-> Seq (EmThread effs systemEvent a)
-> (Seq (EmThread effs systemEvent a),
    Seq (EmThread effs systemEvent a))
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.partition (\EmThread{ThreadId
_threadId :: ThreadId
_threadId :: forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a -> ThreadId
_threadId} -> ThreadId
_threadId ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid) (SchedulerState effs systemEvent a
schedulerState SchedulerState effs systemEvent a
-> Getting
     (Seq (EmThread effs systemEvent a))
     (SchedulerState effs systemEvent a)
     (Seq (EmThread effs systemEvent a))
-> Seq (EmThread effs systemEvent a)
forall s a. s -> Getting a s a -> a
^. Getting
  (Seq (EmThread effs systemEvent a))
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
frozen)
        Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (SchedulerState effs systemEvent a)
 -> Eff effs (Either a (SchedulerState effs systemEvent a)))
-> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall a b. (a -> b) -> a -> b
$
            SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. b -> Either a b
Right (SchedulerState effs systemEvent a
 -> Either a (SchedulerState effs systemEvent a))
-> SchedulerState effs systemEvent a
-> Either a (SchedulerState effs systemEvent a)
forall a b. (a -> b) -> a -> b
$
            SchedulerState effs systemEvent a
schedulerState
                SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Seq (EmThread effs systemEvent a)
 -> Identity (Seq (EmThread effs systemEvent a)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
frozen ((Seq (EmThread effs systemEvent a)
  -> Identity (Seq (EmThread effs systemEvent a)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> Seq (EmThread effs systemEvent a)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq (EmThread effs systemEvent a)
rest
                SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Seq (EmThread effs systemEvent a)
 -> Identity (Seq (EmThread effs systemEvent a)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
normalPrio ((Seq (EmThread effs systemEvent a)
  -> Identity (Seq (EmThread effs systemEvent a)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> Seq (EmThread effs systemEvent a)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Seq (EmThread effs systemEvent a)
thawed
    Right (Exit a
a) -> Either a (SchedulerState effs systemEvent a)
-> Eff effs (Either a (SchedulerState effs systemEvent a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either a (SchedulerState effs systemEvent a)
forall a b. a -> Either a b
Left a
a)


-- | Return a fresh thread ID and increment the counter
nextThreadId :: SchedulerState effs systemEvent a -> (SchedulerState effs systemEvent a, ThreadId)
nextThreadId :: SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a, ThreadId)
nextThreadId SchedulerState effs systemEvent a
s = (SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (ThreadId -> Identity ThreadId)
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens' (SchedulerState effs systemEvent a) ThreadId
lastThreadId ((ThreadId -> Identity ThreadId)
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (ThreadId -> ThreadId)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> ThreadId
ThreadId (Int -> ThreadId) -> (ThreadId -> Int) -> ThreadId -> ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> (ThreadId -> Int) -> ThreadId -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> Int
unThreadId, SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> Getting ThreadId (SchedulerState effs systemEvent a) ThreadId
-> ThreadId
forall s a. s -> Getting a s a -> a
^. Getting ThreadId (SchedulerState effs systemEvent a) ThreadId
forall (effs :: [* -> *]) systemEvent a.
Lens' (SchedulerState effs systemEvent a) ThreadId
lastThreadId)

-- | State of the scheduler before any threads are run.
initialState :: SchedulerState effs systemEvent a
initialState :: SchedulerState effs systemEvent a
initialState = Seq (EmThread effs systemEvent a)
-> Seq (EmThread effs systemEvent a)
-> Seq (EmThread effs systemEvent a)
-> ThreadId
-> HashMap ThreadId (Seq systemEvent)
-> Map Tag (HashSet ThreadId)
-> SchedulerState effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
Seq (EmThread effs systemEvent a)
-> Seq (EmThread effs systemEvent a)
-> Seq (EmThread effs systemEvent a)
-> ThreadId
-> HashMap ThreadId (Seq systemEvent)
-> Map Tag (HashSet ThreadId)
-> SchedulerState effs systemEvent a
SchedulerState Seq (EmThread effs systemEvent a)
forall a. Seq a
Seq.empty Seq (EmThread effs systemEvent a)
forall a. Seq a
Seq.empty Seq (EmThread effs systemEvent a)
forall a. Seq a
Seq.empty ThreadId
initialThreadId HashMap ThreadId (Seq systemEvent)
forall k v. HashMap k v
HashMap.empty Map Tag (HashSet ThreadId)
forall k a. Map k a
Map.empty

-- | Add a suspended thread to the queue.
enqueue :: SuspendedThread effs systemEvent a -> SchedulerState effs systemEvent a -> SchedulerState effs systemEvent a
enqueue :: SuspendedThread effs systemEvent a
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
enqueue WithPriority {Priority
_priority :: Priority
_priority :: forall t. WithPriority t -> Priority
_priority, EmThread effs systemEvent a
_thread :: EmThread effs systemEvent a
_thread :: forall t. WithPriority t -> t
_thread} SchedulerState effs systemEvent a
s =
    case Priority
_priority of
        Priority
Normal   -> SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Seq (EmThread effs systemEvent a)
 -> Identity (Seq (EmThread effs systemEvent a)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
normalPrio ((Seq (EmThread effs systemEvent a)
  -> Identity (Seq (EmThread effs systemEvent a)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (Seq (EmThread effs systemEvent a)
    -> Seq (EmThread effs systemEvent a))
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq (EmThread effs systemEvent a)
-> EmThread effs systemEvent a -> Seq (EmThread effs systemEvent a)
forall s a. Snoc s s a a => s -> a -> s
|> EmThread effs systemEvent a
_thread)
        Priority
Sleeping -> SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Seq (EmThread effs systemEvent a)
 -> Identity (Seq (EmThread effs systemEvent a)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
sleeping ((Seq (EmThread effs systemEvent a)
  -> Identity (Seq (EmThread effs systemEvent a)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (Seq (EmThread effs systemEvent a)
    -> Seq (EmThread effs systemEvent a))
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq (EmThread effs systemEvent a)
-> EmThread effs systemEvent a -> Seq (EmThread effs systemEvent a)
forall s a. Snoc s s a a => s -> a -> s
|> EmThread effs systemEvent a
_thread)
        Priority
Frozen   -> SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Seq (EmThread effs systemEvent a)
 -> Identity (Seq (EmThread effs systemEvent a)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
frozen ((Seq (EmThread effs systemEvent a)
  -> Identity (Seq (EmThread effs systemEvent a)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> (Seq (EmThread effs systemEvent a)
    -> Seq (EmThread effs systemEvent a))
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq (EmThread effs systemEvent a)
-> EmThread effs systemEvent a -> Seq (EmThread effs systemEvent a)
forall s a. Snoc s s a a => s -> a -> s
|> EmThread effs systemEvent a
_thread)

-- | Result of calling 'dequeue'. Either a thread that is ready to receive a
--   message, or no more threads.
data SchedulerDQResult effs systemEvent a
    = AThread (EmThread effs systemEvent a) (Maybe systemEvent) (SchedulerState effs systemEvent a) Priority
    | NoMoreThreads

dequeue :: SchedulerState effs systemEvent a -> SchedulerDQResult effs systemEvent a
dequeue :: SchedulerState effs systemEvent a
-> SchedulerDQResult effs systemEvent a
dequeue SchedulerState effs systemEvent a
s = case SchedulerState effs systemEvent a
-> Maybe
     (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
      Priority)
forall (effs :: [* -> *]) systemEvent a.
SchedulerState effs systemEvent a
-> Maybe
     (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
      Priority)
dequeueThread SchedulerState effs systemEvent a
s of
    Maybe
  (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
   Priority)
Nothing -> SchedulerDQResult effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
SchedulerDQResult effs systemEvent a
NoMoreThreads
    Just (SchedulerState effs systemEvent a
s', EmThread effs systemEvent a
thread, Priority
prio) -> case SchedulerState effs systemEvent a
-> ThreadId
-> Maybe (SchedulerState effs systemEvent a, systemEvent)
forall (effs :: [* -> *]) systemEvent a.
SchedulerState effs systemEvent a
-> ThreadId
-> Maybe (SchedulerState effs systemEvent a, systemEvent)
dequeueMessage SchedulerState effs systemEvent a
s' (EmThread effs systemEvent a -> ThreadId
forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a -> ThreadId
_threadId EmThread effs systemEvent a
thread) of
        Maybe (SchedulerState effs systemEvent a, systemEvent)
Nothing       -> EmThread effs systemEvent a
-> Maybe systemEvent
-> SchedulerState effs systemEvent a
-> Priority
-> SchedulerDQResult effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a
-> Maybe systemEvent
-> SchedulerState effs systemEvent a
-> Priority
-> SchedulerDQResult effs systemEvent a
AThread EmThread effs systemEvent a
thread Maybe systemEvent
forall a. Maybe a
Nothing SchedulerState effs systemEvent a
s' Priority
prio
        Just (SchedulerState effs systemEvent a
s'', systemEvent
m) -> EmThread effs systemEvent a
-> Maybe systemEvent
-> SchedulerState effs systemEvent a
-> Priority
-> SchedulerDQResult effs systemEvent a
forall (effs :: [* -> *]) systemEvent a.
EmThread effs systemEvent a
-> Maybe systemEvent
-> SchedulerState effs systemEvent a
-> Priority
-> SchedulerDQResult effs systemEvent a
AThread EmThread effs systemEvent a
thread (systemEvent -> Maybe systemEvent
forall a. a -> Maybe a
Just systemEvent
m) SchedulerState effs systemEvent a
s'' Priority
prio

-- | Find the next thread that is ready to be resumed.
--   See note [Thread Priority]
dequeueThread :: SchedulerState effs systemEvent  a-> Maybe (SchedulerState effs systemEvent a, EmThread effs systemEvent a, Priority)
dequeueThread :: SchedulerState effs systemEvent a
-> Maybe
     (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
      Priority)
dequeueThread SchedulerState effs systemEvent a
s =
    case SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> Getting
     (Seq (EmThread effs systemEvent a))
     (SchedulerState effs systemEvent a)
     (Seq (EmThread effs systemEvent a))
-> Seq (EmThread effs systemEvent a)
forall s a. s -> Getting a s a -> a
^. Getting
  (Seq (EmThread effs systemEvent a))
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
normalPrio of
        EmThread effs systemEvent a
x :<| Seq (EmThread effs systemEvent a)
xs -> (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
 Priority)
-> Maybe
     (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
      Priority)
forall a. a -> Maybe a
Just (SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Seq (EmThread effs systemEvent a)
 -> Identity (Seq (EmThread effs systemEvent a)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
normalPrio ((Seq (EmThread effs systemEvent a)
  -> Identity (Seq (EmThread effs systemEvent a)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> Seq (EmThread effs systemEvent a)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq (EmThread effs systemEvent a)
xs, EmThread effs systemEvent a
x, Priority
Normal)
        Seq (EmThread effs systemEvent a)
Empty -> case SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> Getting
     (Seq (EmThread effs systemEvent a))
     (SchedulerState effs systemEvent a)
     (Seq (EmThread effs systemEvent a))
-> Seq (EmThread effs systemEvent a)
forall s a. s -> Getting a s a -> a
^. Getting
  (Seq (EmThread effs systemEvent a))
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
sleeping of
                EmThread effs systemEvent a
x :<| Seq (EmThread effs systemEvent a)
xs -> (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
 Priority)
-> Maybe
     (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
      Priority)
forall a. a -> Maybe a
Just (SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (Seq (EmThread effs systemEvent a)
 -> Identity (Seq (EmThread effs systemEvent a)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (Seq (EmThread effs systemEvent a))
sleeping ((Seq (EmThread effs systemEvent a)
  -> Identity (Seq (EmThread effs systemEvent a)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> Seq (EmThread effs systemEvent a)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq (EmThread effs systemEvent a)
xs, EmThread effs systemEvent a
x, Priority
Sleeping)
                Seq (EmThread effs systemEvent a)
Empty    -> Maybe
  (SchedulerState effs systemEvent a, EmThread effs systemEvent a,
   Priority)
forall a. Maybe a
Nothing

-- | Get the first message for the thread.
dequeueMessage :: SchedulerState effs systemEvent a -> ThreadId -> Maybe (SchedulerState effs systemEvent a, systemEvent)
dequeueMessage :: SchedulerState effs systemEvent a
-> ThreadId
-> Maybe (SchedulerState effs systemEvent a, systemEvent)
dequeueMessage SchedulerState effs systemEvent a
s ThreadId
i = do
    Seq systemEvent
mailbox <- SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> Getting
     (Maybe (Seq systemEvent))
     (SchedulerState effs systemEvent a)
     (Maybe (Seq systemEvent))
-> Maybe (Seq systemEvent)
forall s a. s -> Getting a s a -> a
^. (HashMap ThreadId (Seq systemEvent)
 -> Const
      (Maybe (Seq systemEvent)) (HashMap ThreadId (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Const
     (Maybe (Seq systemEvent)) (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (HashMap ThreadId (Seq systemEvent))
mailboxes ((HashMap ThreadId (Seq systemEvent)
  -> Const
       (Maybe (Seq systemEvent)) (HashMap ThreadId (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Const
      (Maybe (Seq systemEvent)) (SchedulerState effs systemEvent a))
-> ((Maybe (Seq systemEvent)
     -> Const (Maybe (Seq systemEvent)) (Maybe (Seq systemEvent)))
    -> HashMap ThreadId (Seq systemEvent)
    -> Const
         (Maybe (Seq systemEvent)) (HashMap ThreadId (Seq systemEvent)))
-> Getting
     (Maybe (Seq systemEvent))
     (SchedulerState effs systemEvent a)
     (Maybe (Seq systemEvent))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap ThreadId (Seq systemEvent))
-> Lens'
     (HashMap ThreadId (Seq systemEvent))
     (Maybe (IxValue (HashMap ThreadId (Seq systemEvent))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap ThreadId (Seq systemEvent))
ThreadId
i
    (systemEvent
x, Seq systemEvent
xs) <- case Seq systemEvent
mailbox of { Seq systemEvent
Empty -> Maybe (systemEvent, Seq systemEvent)
forall a. Maybe a
Nothing; systemEvent
x :<| Seq systemEvent
xs -> (systemEvent, Seq systemEvent)
-> Maybe (systemEvent, Seq systemEvent)
forall a. a -> Maybe a
Just (systemEvent
x, Seq systemEvent
xs) }
    (SchedulerState effs systemEvent a, systemEvent)
-> Maybe (SchedulerState effs systemEvent a, systemEvent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SchedulerState effs systemEvent a
s SchedulerState effs systemEvent a
-> (SchedulerState effs systemEvent a
    -> SchedulerState effs systemEvent a)
-> SchedulerState effs systemEvent a
forall a b. a -> (a -> b) -> b
& (HashMap ThreadId (Seq systemEvent)
 -> Identity (HashMap ThreadId (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall (effs :: [* -> *]) systemEvent a.
Lens'
  (SchedulerState effs systemEvent a)
  (HashMap ThreadId (Seq systemEvent))
mailboxes ((HashMap ThreadId (Seq systemEvent)
  -> Identity (HashMap ThreadId (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> ((Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
    -> HashMap ThreadId (Seq systemEvent)
    -> Identity (HashMap ThreadId (Seq systemEvent)))
-> (Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
-> SchedulerState effs systemEvent a
-> Identity (SchedulerState effs systemEvent a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap ThreadId (Seq systemEvent))
-> Lens'
     (HashMap ThreadId (Seq systemEvent))
     (Maybe (IxValue (HashMap ThreadId (Seq systemEvent))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap ThreadId (Seq systemEvent))
ThreadId
i ((Maybe (Seq systemEvent) -> Identity (Maybe (Seq systemEvent)))
 -> SchedulerState effs systemEvent a
 -> Identity (SchedulerState effs systemEvent a))
-> Maybe (Seq systemEvent)
-> SchedulerState effs systemEvent a
-> SchedulerState effs systemEvent a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq systemEvent -> Maybe (Seq systemEvent)
forall a. a -> Maybe a
Just Seq systemEvent
xs, systemEvent
x)

---
--- Logging etc.
---

data ThreadEvent = Stopped | Resumed | Suspended | Started | Thawed
    deriving stock (ThreadEvent -> ThreadEvent -> Bool
(ThreadEvent -> ThreadEvent -> Bool)
-> (ThreadEvent -> ThreadEvent -> Bool) -> Eq ThreadEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadEvent -> ThreadEvent -> Bool
$c/= :: ThreadEvent -> ThreadEvent -> Bool
== :: ThreadEvent -> ThreadEvent -> Bool
$c== :: ThreadEvent -> ThreadEvent -> Bool
Eq, Eq ThreadEvent
Eq ThreadEvent
-> (ThreadEvent -> ThreadEvent -> Ordering)
-> (ThreadEvent -> ThreadEvent -> Bool)
-> (ThreadEvent -> ThreadEvent -> Bool)
-> (ThreadEvent -> ThreadEvent -> Bool)
-> (ThreadEvent -> ThreadEvent -> Bool)
-> (ThreadEvent -> ThreadEvent -> ThreadEvent)
-> (ThreadEvent -> ThreadEvent -> ThreadEvent)
-> Ord ThreadEvent
ThreadEvent -> ThreadEvent -> Bool
ThreadEvent -> ThreadEvent -> Ordering
ThreadEvent -> ThreadEvent -> ThreadEvent
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 :: ThreadEvent -> ThreadEvent -> ThreadEvent
$cmin :: ThreadEvent -> ThreadEvent -> ThreadEvent
max :: ThreadEvent -> ThreadEvent -> ThreadEvent
$cmax :: ThreadEvent -> ThreadEvent -> ThreadEvent
>= :: ThreadEvent -> ThreadEvent -> Bool
$c>= :: ThreadEvent -> ThreadEvent -> Bool
> :: ThreadEvent -> ThreadEvent -> Bool
$c> :: ThreadEvent -> ThreadEvent -> Bool
<= :: ThreadEvent -> ThreadEvent -> Bool
$c<= :: ThreadEvent -> ThreadEvent -> Bool
< :: ThreadEvent -> ThreadEvent -> Bool
$c< :: ThreadEvent -> ThreadEvent -> Bool
compare :: ThreadEvent -> ThreadEvent -> Ordering
$ccompare :: ThreadEvent -> ThreadEvent -> Ordering
$cp1Ord :: Eq ThreadEvent
Ord, Int -> ThreadEvent -> ShowS
[ThreadEvent] -> ShowS
ThreadEvent -> String
(Int -> ThreadEvent -> ShowS)
-> (ThreadEvent -> String)
-> ([ThreadEvent] -> ShowS)
-> Show ThreadEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadEvent] -> ShowS
$cshowList :: [ThreadEvent] -> ShowS
show :: ThreadEvent -> String
$cshow :: ThreadEvent -> String
showsPrec :: Int -> ThreadEvent -> ShowS
$cshowsPrec :: Int -> ThreadEvent -> ShowS
Show, (forall x. ThreadEvent -> Rep ThreadEvent x)
-> (forall x. Rep ThreadEvent x -> ThreadEvent)
-> Generic ThreadEvent
forall x. Rep ThreadEvent x -> ThreadEvent
forall x. ThreadEvent -> Rep ThreadEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ThreadEvent x -> ThreadEvent
$cfrom :: forall x. ThreadEvent -> Rep ThreadEvent x
Generic)
    deriving anyclass ([ThreadEvent] -> Encoding
[ThreadEvent] -> Value
ThreadEvent -> Encoding
ThreadEvent -> Value
(ThreadEvent -> Value)
-> (ThreadEvent -> Encoding)
-> ([ThreadEvent] -> Value)
-> ([ThreadEvent] -> Encoding)
-> ToJSON ThreadEvent
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ThreadEvent] -> Encoding
$ctoEncodingList :: [ThreadEvent] -> Encoding
toJSONList :: [ThreadEvent] -> Value
$ctoJSONList :: [ThreadEvent] -> Value
toEncoding :: ThreadEvent -> Encoding
$ctoEncoding :: ThreadEvent -> Encoding
toJSON :: ThreadEvent -> Value
$ctoJSON :: ThreadEvent -> Value
ToJSON, Value -> Parser [ThreadEvent]
Value -> Parser ThreadEvent
(Value -> Parser ThreadEvent)
-> (Value -> Parser [ThreadEvent]) -> FromJSON ThreadEvent
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ThreadEvent]
$cparseJSONList :: Value -> Parser [ThreadEvent]
parseJSON :: Value -> Parser ThreadEvent
$cparseJSON :: Value -> Parser ThreadEvent
FromJSON)
    deriving [ThreadEvent] -> Doc ann
ThreadEvent -> Doc ann
(forall ann. ThreadEvent -> Doc ann)
-> (forall ann. [ThreadEvent] -> Doc ann) -> Pretty ThreadEvent
forall ann. [ThreadEvent] -> Doc ann
forall ann. ThreadEvent -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
prettyList :: [ThreadEvent] -> Doc ann
$cprettyList :: forall ann. [ThreadEvent] -> Doc ann
pretty :: ThreadEvent -> Doc ann
$cpretty :: forall ann. ThreadEvent -> Doc ann
Pretty via (PrettyShow ThreadEvent)

data SchedulerLog =
    SchedulerLog
        { SchedulerLog -> ThreadEvent
slEvent  :: ThreadEvent
        , SchedulerLog -> ThreadId
slThread :: ThreadId
        , SchedulerLog -> Tag
slTag    :: Tag
        , SchedulerLog -> Priority
slPrio   :: Priority
        }
    deriving stock (SchedulerLog -> SchedulerLog -> Bool
(SchedulerLog -> SchedulerLog -> Bool)
-> (SchedulerLog -> SchedulerLog -> Bool) -> Eq SchedulerLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchedulerLog -> SchedulerLog -> Bool
$c/= :: SchedulerLog -> SchedulerLog -> Bool
== :: SchedulerLog -> SchedulerLog -> Bool
$c== :: SchedulerLog -> SchedulerLog -> Bool
Eq, Int -> SchedulerLog -> ShowS
[SchedulerLog] -> ShowS
SchedulerLog -> String
(Int -> SchedulerLog -> ShowS)
-> (SchedulerLog -> String)
-> ([SchedulerLog] -> ShowS)
-> Show SchedulerLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchedulerLog] -> ShowS
$cshowList :: [SchedulerLog] -> ShowS
show :: SchedulerLog -> String
$cshow :: SchedulerLog -> String
showsPrec :: Int -> SchedulerLog -> ShowS
$cshowsPrec :: Int -> SchedulerLog -> ShowS
Show, (forall x. SchedulerLog -> Rep SchedulerLog x)
-> (forall x. Rep SchedulerLog x -> SchedulerLog)
-> Generic SchedulerLog
forall x. Rep SchedulerLog x -> SchedulerLog
forall x. SchedulerLog -> Rep SchedulerLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SchedulerLog x -> SchedulerLog
$cfrom :: forall x. SchedulerLog -> Rep SchedulerLog x
Generic)
    deriving anyclass ([SchedulerLog] -> Encoding
[SchedulerLog] -> Value
SchedulerLog -> Encoding
SchedulerLog -> Value
(SchedulerLog -> Value)
-> (SchedulerLog -> Encoding)
-> ([SchedulerLog] -> Value)
-> ([SchedulerLog] -> Encoding)
-> ToJSON SchedulerLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SchedulerLog] -> Encoding
$ctoEncodingList :: [SchedulerLog] -> Encoding
toJSONList :: [SchedulerLog] -> Value
$ctoJSONList :: [SchedulerLog] -> Value
toEncoding :: SchedulerLog -> Encoding
$ctoEncoding :: SchedulerLog -> Encoding
toJSON :: SchedulerLog -> Value
$ctoJSON :: SchedulerLog -> Value
ToJSON, Value -> Parser [SchedulerLog]
Value -> Parser SchedulerLog
(Value -> Parser SchedulerLog)
-> (Value -> Parser [SchedulerLog]) -> FromJSON SchedulerLog
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SchedulerLog]
$cparseJSONList :: Value -> Parser [SchedulerLog]
parseJSON :: Value -> Parser SchedulerLog
$cparseJSON :: Value -> Parser SchedulerLog
FromJSON)

instance Pretty SchedulerLog where
    pretty :: SchedulerLog -> Doc ann
pretty SchedulerLog{ThreadEvent
slEvent :: ThreadEvent
slEvent :: SchedulerLog -> ThreadEvent
slEvent, ThreadId
slThread :: ThreadId
slThread :: SchedulerLog -> ThreadId
slThread, Tag
slTag :: Tag
slTag :: SchedulerLog -> Tag
slTag, Priority
slPrio :: Priority
slPrio :: SchedulerLog -> Priority
slPrio} =
        ThreadId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ThreadId
slThread Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Tag -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Tag
slTag Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ThreadEvent -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ThreadEvent
slEvent Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Priority -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Priority
slPrio)