Try another another thing

Author: michaelpj

lsp-test/func-test/FuncTest.hs

@@ -109,7 +109,7 @@ main = hspec $ do
                   _ -> error "Shouldn't be here"
             ]
 
-      server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
+      server <- async $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
 
       let config = Test.defaultConfig
             { Test.initialWorkspaceFolders = Just [wf0]
@@ -126,6 +126,4 @@ main = hspec $ do
         changeFolders [wf1] []
         changeFolders [wf2] [wf1]
 
-      Left e <- waitCatch server
-      fromException e `shouldBe` Just ExitSuccess
-      
+      wait server

lsp/example/Reactor.hs

@@ -60,18 +60,15 @@ import           Control.Concurrent
 --
 
 main :: IO ()
-main = do
-  run >>= \case
-    0 -> exitSuccess
-    c -> exitWith . ExitFailure $ c
+main = run
 
 -- ---------------------------------------------------------------------
 
 data Config = Config { fooTheBar :: Bool, wibbleFactor :: Int }
   deriving (Generic, J.ToJSON, J.FromJSON, Show)
 
-run :: IO Int
-run = flip E.catches handlers $ do
+run :: IO ()
+run = do
 
   rin  <- atomically newTChan :: IO (TChan ReactorInput)
 
@@ -111,9 +108,6 @@ run = flip E.catches handlers $ do
     serverDefinition
 
   where
-    handlers = [ E.Handler ioExcept
-               , E.Handler someExcept
-               ]
     ioExcept   (e :: E.IOException)       = print e >> return 1
     someExcept (e :: E.SomeException)     = print e >> return 1
 

lsp/example/Simple.hs

@@ -34,7 +34,7 @@ handlers = mconcat
       responder (Right $ Just rsp)
   ]
 
-main :: IO Int
+main :: IO ()
 main = runServer $ ServerDefinition
   { onConfigurationChange = const $ const $ Right ()
   , defaultConfig = ()

lsp/src/Language/LSP/Server/Control.hs

@@ -53,7 +53,7 @@ instance Pretty LspServerLog where
 --     (1) reads from stdin;
 --     (2) writes to stdout; and
 --     (3) logs to stderr and to the client, with some basic filtering.
-runServer :: forall config . ServerDefinition config -> IO Int
+runServer :: forall config . ServerDefinition config -> IO ()
 runServer =
   runServerWithHandles
   ioLogger
@@ -81,7 +81,7 @@ runServerWithHandles ::
     -> Handle
     -- ^ Handle to write output to.
     -> ServerDefinition config
-    -> IO Int         -- exit code
+    -> IO ()
 runServerWithHandles ioLogger logger hin hout serverDefinition = do
 
   hSetBuffering hin NoBuffering
@@ -111,7 +111,7 @@ runServerWith ::
     -> (BS.ByteString -> IO ())
     -- ^ Function to provide output to.
     -> ServerDefinition config
-    -> IO Int         -- exit code
+    -> IO ()
 runServerWith ioLogger logger clientIn clientOut serverDefinition = do
 
   ioLogger <& Starting `WithSeverity` Info
@@ -134,11 +134,10 @@ runServerWith ioLogger logger clientIn clientOut serverDefinition = do
         sendMsg
         recvMsg
 
-  _ <- forkIO serverIn
   -- Bind all the threads together so that any of them terminating will terminate everything
   _ <- Async.withAsync serverOut $ \a1 ->
-      Async.withAsync processingLoop $ \a3 ->
-        Async.waitAny [a1, a3]
+      Async.withAsync serverIn $ \a2 ->
+        Async.withAsync processingLoop $ \a3 ->
+          Async.waitAny [a1, a2, a3]
 
   ioLogger <& Stopping `WithSeverity` Info
-  return 0

lsp/src/Language/LSP/Server/Processing.hs

@@ -107,6 +107,8 @@ processingLoop ioLogger logger vfs serverDefinition sendMsg recvMsg = do
         Just env -> runLspT env $ forever $ do
           msg <- liftIO recvMsg
           processMessage logger msg
+  `E.catch`
+  (\(_ :: RequestedShutdown) -> pure ())
 
 processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Value -> m ()
 processMessage logger val = do
@@ -423,10 +425,14 @@ progressCancelHandler logger (NotificationMessage _ _ (WorkDoneProgressCancelPar
       logger <& ProgressCancel tid `WithSeverity` Debug
       liftIO cancelAction
 
+data RequestedShutdown = RequestedShutdown
+  deriving (Show)
+instance E.Exception RequestedShutdown
+
 exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Exit
 exitNotificationHandler logger _ = do
   logger <& Exiting `WithSeverity` Info
-  liftIO exitSuccess
+  liftIO $ E.throwIO RequestedShutdown
 
 -- | Default Shutdown handler
 shutdownRequestHandler :: Handler IO Shutdown