{-# 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_,
waitThread',
waitThreads',
linkThread,
cancelThread,
concurrentThreads,
concurrentThreads_,
raceThreads,
raceThreads_,
Thread,
unThread,
) where
import Control.Concurrent.Async (Async, AsyncCancelled, cancel)
import qualified Control.Concurrent.Async as Async (
async,
cancel,
concurrently,
concurrently_,
link,
race,
race_,
wait,
waitCatch,
)
import Control.Concurrent.MVar (
newMVar,
readMVar,
)
import qualified Control.Exception.Safe as Safe (catch, catchAsync)
import Control.Monad (
void,
)
import Control.Monad.Reader.Class (MonadReader (ask))
import Core.Program.Context
import Core.Program.Logging
import Core.System.Base
import Core.Text.Rope
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
let v :: MVar Datum
v = Context τ -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom 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
Datum
datum <- MVar Datum -> IO Datum
forall a. MVar a -> IO a
readMVar MVar Datum
v
MVar Datum
v' <- Datum -> IO (MVar Datum)
forall a. a -> IO (MVar a)
newMVar Datum
datum
let context' :: Context τ
context' =
Context τ
context
{ $sel:startTimeFrom:Context :: MVar TimeStamp
startTimeFrom = MVar TimeStamp
i'
, $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v'
}
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
IO α -> (SomeException -> IO α) -> IO α
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
(Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context' Program τ α
program)
( \(SomeException
e :: SomeException) ->
let text :: Rope
text = String -> Rope
forall α. Textual α => α -> Rope
intoRope (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
in do
Context τ -> Program τ () -> IO ()
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context' (Program τ () -> IO ()) -> Program τ () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
warn Rope
"Uncaught exception in thread"
Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug Rope
"e" Rope
text
SomeException -> IO α
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw SomeException
e
)
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
$ do
IO α -> (AsyncCancelled -> IO α) -> IO α
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catchAsync
(Async α -> IO α
forall a. Async a -> IO a
Async.wait Async α
a)
( \(AsyncCancelled
e :: AsyncCancelled) -> do
Async α -> IO ()
forall a. Async a -> IO ()
cancel Async α
a
AsyncCancelled -> IO α
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw AsyncCancelled
e
)
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
waitThread' :: Thread α -> Program τ (Either SomeException α)
waitThread' :: Thread α -> Program τ (Either SomeException α)
waitThread' (Thread Async α
a) = IO (Either SomeException α) -> Program τ (Either SomeException α)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException α) -> Program τ (Either SomeException α))
-> IO (Either SomeException α)
-> Program τ (Either SomeException α)
forall a b. (a -> b) -> a -> b
$ do
IO (Either SomeException α)
-> (AsyncCancelled -> IO (Either SomeException α))
-> IO (Either SomeException α)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catchAsync
( do
Either SomeException α
result <- Async α -> IO (Either SomeException α)
forall a. Async a -> IO (Either SomeException a)
Async.waitCatch Async α
a
Either SomeException α -> IO (Either SomeException α)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException α
result
)
( \(AsyncCancelled
e :: AsyncCancelled) -> do
Async α -> IO ()
forall a. Async a -> IO ()
cancel Async α
a
AsyncCancelled -> IO (Either SomeException α)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw AsyncCancelled
e
)
waitThreads' :: [Thread α] -> Program τ [Either SomeException α]
waitThreads' :: [Thread α] -> Program τ [Either SomeException α]
waitThreads' [Thread α]
ts = IO [Either SomeException α] -> Program τ [Either SomeException α]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either SomeException α] -> Program τ [Either SomeException α])
-> IO [Either SomeException α]
-> Program τ [Either SomeException α]
forall a b. (a -> b) -> a -> b
$ do
let as :: [Async α]
as = (Thread α -> Async α) -> [Thread α] -> [Async α]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Thread α -> Async α
forall α. Thread α -> Async α
unThread [Thread α]
ts
IO [Either SomeException α]
-> (AsyncCancelled -> IO [Either SomeException α])
-> IO [Either SomeException α]
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catchAsync
( do
[Either SomeException α]
results <- (Async α -> IO (Either SomeException α))
-> [Async α] -> IO [Either SomeException α]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Async α -> IO (Either SomeException α)
forall a. Async a -> IO (Either SomeException a)
Async.waitCatch [Async α]
as
[Either SomeException α] -> IO [Either SomeException α]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Either SomeException α]
results
)
( \(AsyncCancelled
e :: AsyncCancelled) -> do
(Async α -> IO ()) -> [Async α] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async α -> IO ()
forall a. Async a -> IO ()
cancel [Async α]
as
AsyncCancelled -> IO [Either SomeException α]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw AsyncCancelled
e
)
linkThread :: Thread α -> Program τ ()
linkThread :: Thread α -> Program τ ()
linkThread (Thread Async α
a) = do
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
Async α -> IO ()
forall a. Async a -> IO ()
Async.link Async α
a
cancelThread :: Thread α -> Program τ ()
cancelThread :: Thread α -> Program τ ()
cancelThread (Thread Async α
a) = do
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
Async α -> IO ()
forall a. Async a -> IO ()
Async.cancel Async α
a
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)