X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=b98dca84f975ccfd10035b27a43476e969090002;hb=6fa77d1acd9f1c76383ac179b36bacd9d22f2819;hp=d43d11a1f79b5c2df46285f54e42ea22bc2bf399;hpb=98d03792f46f3ac870c010a78944822569e76763;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index d43d11a..b98dca8 100644
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -14,7 +14,7 @@ module Language.Haskell.LSP.Test.Session
   , SessionMessage(..)
   , SessionContext(..)
   , SessionState(..)
-  , runSessionWithHandles
+  , runSession'
   , get
   , put
   , modify
@@ -110,11 +110,14 @@ data SessionConfig = SessionConfig
   -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False.
   --
   -- @since 0.9.0.0
+  , initialWorkspaceFolders :: Maybe [WorkspaceFolder]
+  -- ^ The initial workspace folders to send in the @initialize@ request.
+  -- Defaults to Nothing.
   }
 
 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
 defaultConfig :: SessionConfig
-defaultConfig = SessionConfig 60 False False True Nothing False
+defaultConfig = SessionConfig 60 False False True Nothing False Nothing
 
 instance Default SessionConfig where
   def = defaultConfig
@@ -167,7 +170,7 @@ data SessionState = SessionState
   -- ^ The last received message from the server.
   -- Used for providing exception information
   , lastReceivedMessage :: Maybe FromServerMessage
-  , curDynCaps :: Map.Map T.Text Registration
+  , curDynCaps :: Map.Map T.Text SomeRegistration
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
   }
@@ -201,8 +204,8 @@ instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m)
   get = lift get
   put = lift . put
 
-runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession context state (Session session) = runReaderT (runStateT conduit state) context
+runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
+runSessionMonad context state (Session session) = runReaderT (runStateT conduit state) context
   where
     conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
 
@@ -232,9 +235,9 @@ runSession context state (Session session) = runReaderT (runStateT conduit state
 
 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 -- It also does not automatically send initialize and exit messages.
-runSessionWithHandles :: Handle -- ^ Server in
+runSession' :: Handle -- ^ Server in
             -> Handle -- ^ Server out
-                      -> ProcessHandle -- ^ Server process
+            -> Maybe ProcessHandle -- ^ Server process
             -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
             -> SessionConfig
             -> ClientCapabilities
@@ -242,7 +245,7 @@ runSessionWithHandles :: Handle -- ^ Server in
             -> Session () -- ^ To exit the Server properly
             -> Session a
             -> IO a
-runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
+runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exitServer session = do
   absRootDir <- canonicalizePath rootDir
 
   hSetBuffering serverIn  NoBuffering
@@ -261,28 +264,27 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro
 
   let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
       initState vfs = SessionState 0 vfs mempty False Nothing mempty
-      runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
+      runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
 
       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
       serverListenerLauncher =
         forkIO $ catch (serverHandler serverOut context) errorHandler
-      server = (Just serverIn, Just serverOut, Nothing, serverProc)
       msgTimeoutMs = messageTimeout config * 10^6
       serverAndListenerFinalizer tid = do
-        finally (timeout msgTimeoutMs (runSession' exitServer)) $ do
+        let cleanup
+              | Just sp <- mServerProc = do
+                  -- Give the server some time to exit cleanly
+                  timeout msgTimeoutMs (waitForProcess sp)
+                  cleanupProcess (Just serverIn, Just serverOut, Nothing, sp)
+              | otherwise = pure ()
+        finally (timeout msgTimeoutMs (runSession' exitServer))
                 -- Make sure to kill the listener first, before closing
                 -- handles etc via cleanupProcess
-          killThread tid
-          -- Give the server some time to exit cleanly
-          -- It makes the server hangs in windows so we have to avoid it
-#ifndef mingw32_HOST_OS
-          timeout msgTimeoutMs (waitForProcess serverProc)
-#endif
-          cleanupProcess server
+                (killThread tid >> cleanup)
 
   (result, _) <- bracket serverListenerLauncher
                          serverAndListenerFinalizer
-                         (const $ initVFS $ \vfs -> runSession context (initState vfs) session)
+                         (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)
   return result
 
 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
@@ -295,12 +297,12 @@ updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
 
 -- Keep track of dynamic capability registration
 updateState (FromServerMess SClientRegisterCapability req) = do
-  let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations
+  let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations
   modify $ \s ->
     s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }
 
 updateState (FromServerMess SClientUnregisterCapability req) = do
-  let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations
+  let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations
   modify $ \s ->
     let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs
     in s { curDynCaps = newCurDynCaps }