diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index a38da77f38..6d141c7ef3 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -10,10 +10,13 @@ module Development.IDE.Core.WorkerThread (withWorkerQueue, awaitRunInThread) where -import Control.Concurrent.Async (withAsync) +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)) @@ -42,13 +45,15 @@ withWorkerQueue workerAction = ContT $ \mainAction -> do workerAction l -- | '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 q act = do -- Take an action from TQueue, run it and -- use barrier to wait for the result barrier <- newBarrier - atomically $ writeTQueue q $ do - res <- act - signalBarrier barrier res - waitBarrier barrier + atomically $ writeTQueue q $ try act >>= signalBarrier barrier + resultOrException <- waitBarrier barrier + case resultOrException of + Left e -> throwIO (e :: SomeException) + Right r -> return r