{-
Module : Development.IDE.Core.WorkerThread
Author : @soulomoon
SPDX-License-Identifier: Apache-2.0

Description : This module provides an API for managing worker threads in the IDE.
see Note [Serializing runs in separate thread]
-}
module Development.IDE.Core.WorkerThread
    (withWorkerQueue, awaitRunInThread)
 where

import           Control.Concurrent.Async  (AsyncCancelled (AsyncCancelled),
                                            withAsync)
import           Control.Concurrent.STM
import           Control.Concurrent.Strict (newBarrier, signalBarrier,
                                            waitBarrier)
import           Control.Exception.Safe    (Exception (fromException),
                                            SomeException, throwIO, try)
import           Control.Monad             (forever)
import           Control.Monad.Cont        (ContT (ContT))

{-
Note [Serializing runs in separate thread]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We often want to take long-running actions using some resource that cannot be shared.
In this instance it is useful to have a queue of jobs to run using the resource.
Like the db writes, session loading in session loader, shake session restarts.

Originally we used various ways to implement this, but it was hard to maintain and error prone.
Moreover, we can not stop these threads uniformly when we are shutting down the server.
-}

-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker
-- thread which polls the queue for requests and runs the given worker
-- function on them.
withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t)
withWorkerQueue :: forall t a. (t -> IO a) -> ContT () IO (TQueue t)
withWorkerQueue t -> IO a
workerAction = ((TQueue t -> IO ()) -> IO ()) -> ContT () IO (TQueue t)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((TQueue t -> IO ()) -> IO ()) -> ContT () IO (TQueue t))
-> ((TQueue t -> IO ()) -> IO ()) -> ContT () IO (TQueue t)
forall a b. (a -> b) -> a -> b
$ \TQueue t -> IO ()
mainAction -> do
    TQueue t
q <- IO (TQueue t)
forall a. IO (TQueue a)
newTQueueIO
    IO Any -> (Async Any -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (TQueue t -> IO Any
forall {b}. TQueue t -> IO b
writerThread TQueue t
q) ((Async Any -> IO ()) -> IO ()) -> (Async Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async Any
_ -> TQueue t -> IO ()
mainAction TQueue t
q
    where
        writerThread :: TQueue t -> IO b
writerThread TQueue t
q =
            IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO a -> IO b) -> IO a -> IO b
forall a b. (a -> b) -> a -> b
$ do
                t
l <- STM t -> IO t
forall a. STM a -> IO a
atomically (STM t -> IO t) -> STM t -> IO t
forall a b. (a -> b) -> a -> b
$ TQueue t -> STM t
forall a. TQueue a -> STM a
readTQueue TQueue t
q
                t -> IO a
workerAction t
l

-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,
-- and then blocks until the result is computed. If the action throws an
-- non-async exception, it is rethrown in the calling thread.
awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result
awaitRunInThread :: forall result. TQueue (IO ()) -> IO result -> IO result
awaitRunInThread TQueue (IO ())
q IO result
act = do
    -- Take an action from TQueue, run it and
    -- use barrier to wait for the result
    Barrier (Either SomeException result)
barrier <- IO (Barrier (Either SomeException result))
forall a. IO (Barrier a)
newBarrier
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (IO ()) -> IO () -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (IO ())
q (IO () -> STM ()) -> IO () -> STM ()
forall a b. (a -> b) -> a -> b
$ IO result -> IO (Either SomeException result)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try IO result
act IO (Either SomeException result)
-> (Either SomeException result -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Barrier (Either SomeException result)
-> Either SomeException result -> IO ()
forall a. HasCallStack => Barrier a -> a -> IO ()
signalBarrier Barrier (Either SomeException result)
barrier
    Either SomeException result
resultOrException <- Barrier (Either SomeException result)
-> IO (Either SomeException result)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException result)
barrier
    case Either SomeException result
resultOrException of
        Left SomeException
e  -> SomeException -> IO result
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (SomeException
e :: SomeException)
        Right result
r -> result -> IO result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return result
r