Bubble up exceptions thrown on server listener thread

[lsp-test.git] / src / Language / Haskell / LSP / Test / Session.hs

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index dc3c6ff870cccbb488b490b896b6d7bdab9f58f1..700d9ccc84c233314f9c581bfd6bf8f810c8c1d5 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -32,11 +32,10 @@ import Control.Concurrent hiding (yield)
 import Control.Exception
 import Control.Lens hiding (List)
 import Control.Monad
-import Control.Monad.Fail
 import Control.Monad.IO.Class
 import Control.Monad.Except
 #if __GLASGOW_HASKELL__ >= 806
-import qualified Control.Monad.Fail as Fail
+import Control.Monad.Fail
 #endif
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import qualified Control.Monad.Trans.Reader as Reader (ask)
@@ -93,7 +92,7 @@ data SessionConfig = SessionConfig
 
 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
 defaultConfig :: SessionConfig
-defaultConfig = SessionConfig 60 False True True Nothing
+defaultConfig = SessionConfig 60 False False True Nothing
 
 instance Default SessionConfig where
   def = defaultConfig
@@ -202,13 +201,14 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir sessi
   messageChan <- newChan
   initRsp <- newEmptyMVar
 
+  mainThreadId <- myThreadId
+
   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
       initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
-
-  threadId <- forkIO $ void $ serverHandler serverOut context
-  (result, _) <- runSession context initState session
-
-  killThread threadId
+      launchServerHandler = forkIO $ catch (serverHandler serverOut context)
+                                           (throwTo mainThreadId :: SessionException -> IO ())
+  (result, _) <- bracket launchServerHandler killThread $
+    const $ runSession context initState session
 
   return result
 
@@ -335,3 +335,4 @@ logMsg t msg = do
           | otherwise       = Cyan
 
         showPretty = B.unpack . encodePretty
+