{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Threads (
forkThread,
waitThread,
waitThread_,
concurrentThreads,
concurrentThreads_,
raceThreads,
raceThreads_,
Thread,
unThread,
) where
import Control.Concurrent.Async (Async)
import qualified Control.Concurrent.Async as Async (
async,
concurrently,
concurrently_,
link,
race,
race_,
wait,
)
import Control.Concurrent.MVar (
newMVar,
readMVar,
)
import Control.Monad (
void,
)
import Control.Monad.Reader.Class (MonadReader (ask))
import Core.Program.Context
import Core.System.Base
newtype Thread α = Thread (Async α)
unThread :: Thread α -> Async α
unThread :: Thread α -> Async α
unThread (Thread Async α
a) = Async α
a
forkThread :: Program τ α -> Program τ (Thread α)
forkThread :: Program τ α -> Program τ (Thread α)
forkThread Program τ α
program = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
let i :: MVar TimeStamp
i = Context τ -> MVar TimeStamp
forall τ. Context τ -> MVar TimeStamp
startTimeFrom Context τ
context
IO (Thread α) -> Program τ (Thread α)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Thread α) -> Program τ (Thread α))
-> IO (Thread α) -> Program τ (Thread α)
forall a b. (a -> b) -> a -> b
$ do
TimeStamp
start <- MVar TimeStamp -> IO TimeStamp
forall a. MVar a -> IO a
readMVar MVar TimeStamp
i
MVar TimeStamp
i' <- TimeStamp -> IO (MVar TimeStamp)
forall a. a -> IO (MVar a)
newMVar TimeStamp
start
let context' :: Context τ
context' = Context τ
context{$sel:startTimeFrom:Context :: MVar TimeStamp
startTimeFrom = MVar TimeStamp
i'}
Async α
a <- IO α -> IO (Async α)
forall a. IO a -> IO (Async a)
Async.async (IO α -> IO (Async α)) -> IO α -> IO (Async α)
forall a b. (a -> b) -> a -> b
$ do
Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context' Program τ α
program
Async α -> IO ()
forall a. Async a -> IO ()
Async.link Async α
a
Thread α -> IO (Thread α)
forall (m :: * -> *) a. Monad m => a -> m a
return (Async α -> Thread α
forall α. Async α -> Thread α
Thread Async α
a)
waitThread :: Thread α -> Program τ α
waitThread :: Thread α -> Program τ α
waitThread (Thread Async α
a) = IO α -> Program τ α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO α -> Program τ α) -> IO α -> Program τ α
forall a b. (a -> b) -> a -> b
$ Async α -> IO α
forall a. Async a -> IO a
Async.wait Async α
a
waitThread_ :: Thread α -> Program τ ()
waitThread_ :: Thread α -> Program τ ()
waitThread_ = Program τ α -> Program τ ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Program τ α -> Program τ ())
-> (Thread α -> Program τ α) -> Thread α -> Program τ ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Thread α -> Program τ α
forall α τ. Thread α -> Program τ α
waitThread
concurrentThreads :: Program τ α -> Program τ β -> Program τ (α, β)
concurrentThreads :: Program τ α -> Program τ β -> Program τ (α, β)
concurrentThreads Program τ α
one Program τ β
two = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO (α, β) -> Program τ (α, β)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (α, β) -> Program τ (α, β)) -> IO (α, β) -> Program τ (α, β)
forall a b. (a -> b) -> a -> b
$ do
IO α -> IO β -> IO (α, β)
forall a b. IO a -> IO b -> IO (a, b)
Async.concurrently
(Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ α
one)
(Context τ -> Program τ β -> IO β
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ β
two)
concurrentThreads_ :: Program τ α -> Program τ β -> Program τ ()
concurrentThreads_ :: Program τ α -> Program τ β -> Program τ ()
concurrentThreads_ Program τ α
one Program τ β
two = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
IO α -> IO β -> IO ()
forall a b. IO a -> IO b -> IO ()
Async.concurrently_
(Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ α
one)
(Context τ -> Program τ β -> IO β
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ β
two)
raceThreads :: Program τ α -> Program τ β -> Program τ (Either α β)
raceThreads :: Program τ α -> Program τ β -> Program τ (Either α β)
raceThreads Program τ α
one Program τ β
two = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO (Either α β) -> Program τ (Either α β)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either α β) -> Program τ (Either α β))
-> IO (Either α β) -> Program τ (Either α β)
forall a b. (a -> b) -> a -> b
$ do
IO α -> IO β -> IO (Either α β)
forall a b. IO a -> IO b -> IO (Either a b)
Async.race
(Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ α
one)
(Context τ -> Program τ β -> IO β
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ β
two)
raceThreads_ :: Program τ α -> Program τ β -> Program τ ()
raceThreads_ :: Program τ α -> Program τ β -> Program τ ()
raceThreads_ Program τ α
one Program τ β
two = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
IO α -> IO β -> IO ()
forall a b. IO a -> IO b -> IO ()
Async.race_
(Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ α
one)
(Context τ -> Program τ β -> IO β
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ β
two)