From 42c31d30c5ec46b508e7bf59e123f816b615a57b Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Sun, 28 Jan 2024 20:05:36 +0000 Subject: [PATCH] WIP --- lsp/src/Language/LSP/Server/Core.hs | 49 +++++++++++++++-------- lsp/src/Language/LSP/Server/Processing.hs | 12 +++++- 2 files changed, 43 insertions(+), 18 deletions(-) diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 2a67539c..78adc70e 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -562,39 +562,54 @@ registerCapability :: Handler f m -> f (Maybe (RegistrationToken m)) registerCapability method regOpts f = do - clientCaps <- resClientCapabilities <$> getLspEnv handlers <- resHandlers <$> getLspEnv let alreadyStaticallyRegistered = case splitClientMethod method of IsClientNot -> SMethodMap.member method $ notHandlers handlers IsClientReq -> SMethodMap.member method $ reqHandlers handlers IsClientEither -> error "Cannot register capability for custom methods" - go clientCaps alreadyStaticallyRegistered + go alreadyStaticallyRegistered where -- If the server has already registered statically, don't dynamically register -- as per the spec - go _clientCaps True = pure Nothing - go clientCaps False - -- First, check to see if the client supports dynamic registration on this method - | dynamicRegistrationSupported method clientCaps = do - uuid <- liftIO $ UUID.toText <$> getStdRandom random - let registration = L.TRegistration uuid method (Just regOpts) - params = L.RegistrationParams [toUntypedRegistration registration] - regId = RegistrationId uuid - rio <- askUnliftIO + go True = pure Nothing + go False = do + rio <- askUnliftIO + mtoken <- trySendRegistration method regOpts + case mtoken of + Just token@(RegistrationToken _ regId) -> do ~() <- case splitClientMethod method of IsClientNot -> modifyState resRegistrationsNot $ \oldRegs -> let pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) - in SMethodMap.insert method pair oldRegs + in SMethodMap.insert method pair oldRegs IsClientReq -> modifyState resRegistrationsReq $ \oldRegs -> let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) - in SMethodMap.insert method pair oldRegs + in SMethodMap.insert method pair oldRegs IsClientEither -> error "Cannot register capability for custom methods" - -- TODO: handle the scenario where this returns an error - _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () + pure $ Just token + Nothing -> pure Nothing - pure (Just (RegistrationToken method regId)) - | otherwise = pure Nothing +trySendRegistration :: + forall f t (m :: Method ClientToServer t) config. + MonadLsp config f => + SClientMethod m -> + RegistrationOptions m -> + f (Maybe (RegistrationToken m)) +trySendRegistration method regOpts = do + clientCaps <- resClientCapabilities <$> getLspEnv + -- First, check to see if the client supports dynamic registration on this method + if dynamicRegistrationSupported method clientCaps + then do + uuid <- liftIO $ UUID.toText <$> getStdRandom random + let registration = L.TRegistration uuid method (Just regOpts) + params = L.RegistrationParams [toUntypedRegistration registration] + regId = RegistrationId uuid + + -- TODO: handle the scenario where this returns an error + _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () + + pure (Just $ RegistrationToken method regId) + else pure Nothing {- | Sends a @client/unregisterCapability@ request and removes the handler for that associated registration. diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index 5376048b..ad6ddc9b 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -77,6 +77,7 @@ data LspProcessingLog | MessageProcessingError BSL.ByteString String | forall m. MissingHandler Bool (SClientMethod m) | ProgressCancel ProgressToken + | forall m. CantRegister (SMethod m) | Exiting deriving instance Show LspProcessingLog @@ -93,6 +94,7 @@ instance Pretty LspProcessingLog where ] pretty (MissingHandler _ m) = "LSP: no handler for:" <+> pretty m pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> pretty tid + pretty (CantRegister m) = "LSP: can't register dynamically for:" <+> pretty m pretty Exiting = "LSP: Got exit, exiting" processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> BSL.ByteString -> m () @@ -428,7 +430,7 @@ handle logger m msg = SMethod_WorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg -- See Note [LSP configuration] - SMethod_Initialized -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg + SMethod_Initialized -> handle' logger (Just $ \_ -> initialDynamicRegistrations logger >> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg SMethod_TextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg SMethod_TextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg SMethod_TextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg @@ -531,6 +533,14 @@ shutdownRequestHandler :: Handler IO Method_Shutdown shutdownRequestHandler _req k = do k $ Right Null +initialDynamicRegistrations :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> m () +initialDynamicRegistrations logger = do + section <- LspT $ asks resConfigSection + mtoken <- trySendRegistration SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationRegistrationOptions (Just $ InL section)) + case mtoken of + Nothing -> logger <& (CantRegister SMethod_WorkspaceDidChangeConfiguration) `WithSeverity` Warning + Just _ -> pure () + {- | Try to find the configuration section in an object that might represent "all" the settings. The heuristic we use is to look for a property with the right name, and use that if we find it. Otherwise we fall back to the whole object.