X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=a6474bb2ca1b0b9b9bd0964960c5a4670c48cadb;hb=396083e05601ec9ce9f654f18054471634f7efa0;hp=9e4aa81aa1fc960ccd1cbc48509f44541b9ceb8e;hpb=753acba85dddb7e8a6375358a1ab2d14fe8d29f6;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 9e4aa81..a6474bb 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,7 +14,7 @@ module Language.Haskell.LSP.Test.Session , SessionMessage(..) , SessionContext(..) , SessionState(..) - , runSessionWithHandles + , runSession' , get , put , modify @@ -59,7 +60,6 @@ import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Data.Function -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens @@ -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 @@ -160,14 +163,14 @@ bumpTimeoutId prev = do data SessionState = SessionState { - curReqId :: LspId + curReqId :: Int , vfs :: VFS , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] , overridingTimeout :: Bool -- ^ 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) @@ -219,8 +222,8 @@ runSession context state (Session session) = runReaderT (runStateT conduit state yield msg chanSource - isLogNotification (ServerMessage (NotShowMessage _)) = True - isLogNotification (ServerMessage (NotLogMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True isLogNotification _ = False watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -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 @@ -260,8 +263,8 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro mainThreadId <- myThreadId let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty - runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses + initState vfs = SessionState 0 vfs mempty False Nothing mempty + runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses errorHandler = throwTo mainThreadId :: SessionException -> IO () serverListenerLauncher = @@ -269,20 +272,22 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro server = (Just serverIn, Just serverOut, Nothing, serverProc) msgTimeoutMs = messageTimeout config * 10^6 serverAndListenerFinalizer tid = do + let cleanup + | Just sp <- mServerProc = cleanupProcess (Just serverIn, Just serverOut, Nothing, sp) + | otherwise = pure () finally (timeout msgTimeoutMs (runSession' exitServer)) $ do -- 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 + cleanup (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer - (const $ runSession' session) + (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -294,25 +299,25 @@ updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () -- Keep track of dynamic capability registration -updateState (ReqRegisterCapability req) = do - let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations +updateState (FromServerMess SClientRegisterCapability req) = do + 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 (ReqUnregisterCapability req) = do - let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations +updateState (FromServerMess SClientUnregisterCapability req) = do + let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations modify $ \s -> let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs in s { curDynCaps = newCurDynCaps } -updateState (NotPublishDiagnostics n) = do +updateState (FromServerMess STextDocumentPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) in s { curDiagnostics = newDiags } -updateState (ReqApplyWorkspaceEdit r) = do +updateState (FromServerMess SWorkspaceApplyEdit r) = do -- First, prefer the versioned documentChanges field allChangeParams <- case r ^. params . edit . documentChanges of @@ -335,7 +340,7 @@ updateState (ReqApplyWorkspaceEdit r) = do mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session - forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange) -- Update VFS to new document versions let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams @@ -358,7 +363,7 @@ updateState (ReqApplyWorkspaceEdit r) = do let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents - msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) + msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item) liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) modifyM $ \s -> do