mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-11-20 09:59:06 +03:00
capture error in worker thread (#4342)
* use safe try that does not catch the asyncException
This commit is contained in:
parent
012e809054
commit
f0ba40baf6
@ -10,10 +10,13 @@ module Development.IDE.Core.WorkerThread
|
|||||||
(withWorkerQueue, awaitRunInThread)
|
(withWorkerQueue, awaitRunInThread)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Concurrent.Async (withAsync)
|
import Control.Concurrent.Async (AsyncCancelled (AsyncCancelled),
|
||||||
|
withAsync)
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Concurrent.Strict (newBarrier, signalBarrier,
|
import Control.Concurrent.Strict (newBarrier, signalBarrier,
|
||||||
waitBarrier)
|
waitBarrier)
|
||||||
|
import Control.Exception.Safe (Exception (fromException),
|
||||||
|
SomeException, throwIO, try)
|
||||||
import Control.Monad (forever)
|
import Control.Monad (forever)
|
||||||
import Control.Monad.Cont (ContT (ContT))
|
import Control.Monad.Cont (ContT (ContT))
|
||||||
|
|
||||||
@ -42,13 +45,15 @@ withWorkerQueue workerAction = ContT $ \mainAction -> do
|
|||||||
workerAction l
|
workerAction l
|
||||||
|
|
||||||
-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,
|
-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,
|
||||||
-- and then blocks until the result is computed.
|
-- 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 :: TQueue (IO ()) -> IO result -> IO result
|
||||||
awaitRunInThread q act = do
|
awaitRunInThread q act = do
|
||||||
-- Take an action from TQueue, run it and
|
-- Take an action from TQueue, run it and
|
||||||
-- use barrier to wait for the result
|
-- use barrier to wait for the result
|
||||||
barrier <- newBarrier
|
barrier <- newBarrier
|
||||||
atomically $ writeTQueue q $ do
|
atomically $ writeTQueue q $ try act >>= signalBarrier barrier
|
||||||
res <- act
|
resultOrException <- waitBarrier barrier
|
||||||
signalBarrier barrier res
|
case resultOrException of
|
||||||
waitBarrier barrier
|
Left e -> throwIO (e :: SomeException)
|
||||||
|
Right r -> return r
|
||||||
|
Loading…
Reference in New Issue
Block a user