diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for lsp +## 2.5.0.0 + +- The server will now reject messages sent after `shutdown` has been received. +- There is a `shutdownBarrier` member in the server state which can be used to + conveniently run actions when shutdown is triggered. + ## 2.4.0.0 - Server-created progress now will not send reports until and unless the client diff --git a/example/Reactor.hs b/example/Reactor.hs --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -1,12 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeInType #-} --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} {- | This is an example language server built with haskell-lsp using a 'Reactor' @@ -36,7 +33,6 @@ import Data.Aeson qualified as J import Data.Int (Int32) import Data.Text qualified as T -import Data.Text.Prettyprint.Doc import GHC.Generics (Generic) import Language.LSP.Diagnostics import Language.LSP.Logging (defaultClientLogger) @@ -45,6 +41,7 @@ import Language.LSP.Protocol.Types qualified as LSP import Language.LSP.Server import Language.LSP.VFS +import Prettyprinter import System.Exit import System.IO diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp -version: 2.4.0.0 +version: 2.5.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -26,10 +26,14 @@ type: git location: https://github.com/haskell/lsp +common warnings + ghc-options: -Wall -Wunused-packages -Wno-unticked-promoted-constructors + library + import: warnings hs-source-dirs: src default-language: GHC2021 - ghc-options: -Wall -fprint-explicit-kinds + ghc-options: -fprint-explicit-kinds reexported-modules: , Language.LSP.Protocol.Types , Language.LSP.Protocol.Lens @@ -47,7 +51,6 @@ Language.LSP.Server.Core Language.LSP.Server.Processing - ghc-options: -Wall build-depends: , aeson >=2 && <2.3 , async ^>=2.2 @@ -59,15 +62,15 @@ , data-default ^>=0.7 , directory ^>=1.3 , exceptions ^>=0.10 + , extra ^>=1.7 , filepath >=1.4 && < 1.6 , hashable ^>=1.4 , lens >=5.1 && <5.3 , lens-aeson ^>=1.2 - , lsp-types ^>=2.1 + , lsp-types ^>=2.2 , mtl >=2.2 && <2.4 , prettyprinter ^>=1.7 , random ^>=1.2 - , row-types ^>=1.0 , sorted-list ^>=0.2.1 , stm ^>=2.5 , text >=1 && <2.2 @@ -78,10 +81,10 @@ , uuid >=1.3 executable lsp-demo-reactor-server + import: warnings main-is: Reactor.hs hs-source-dirs: example default-language: GHC2021 - ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , aeson , base @@ -97,10 +100,10 @@ buildable: False executable lsp-demo-simple-server + import: warnings main-is: Simple.hs hs-source-dirs: example default-language: GHC2021 - ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , base , lsp @@ -115,6 +118,7 @@ default: False test-suite lsp-test + import: warnings type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs @@ -128,12 +132,11 @@ , containers , hspec , lsp - , row-types , sorted-list , text , text-rope , unordered-containers build-tool-depends: hspec-discover:hspec-discover - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: GHC2021 diff --git a/src/Language/LSP/Diagnostics.hs b/src/Language/LSP/Diagnostics.hs --- a/src/Language/LSP/Diagnostics.hs +++ b/src/Language/LSP/Diagnostics.hs @@ -50,7 +50,7 @@ -- --------------------------------------------------------------------- partitionBySource :: [J.Diagnostic] -> DiagnosticsBySource -partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, (SL.singleton d))) diags +partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, SL.singleton d)) diags -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Server.hs b/src/Language/LSP/Server.hs --- a/src/Language/LSP/Server.hs +++ b/src/Language/LSP/Server.hs @@ -35,6 +35,10 @@ requestConfigUpdate, tryChangeConfig, + -- * Shutdown + isShuttingDown, + waitShuttingDown, + -- * VFS getVirtualFile, getVirtualFiles, diff --git a/src/Language/LSP/Server/Control.hs b/src/Language/LSP/Server/Control.hs --- a/src/Language/LSP/Server/Control.hs +++ b/src/Language/LSP/Server/Control.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} module Language.LSP.Server.Control ( -- * Running @@ -30,12 +26,12 @@ import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL -import Data.Text.Prettyprint.Doc import Language.LSP.Logging (defaultClientLogger) import Language.LSP.Protocol.Message import Language.LSP.Server.Core import Language.LSP.Server.Processing qualified as Processing import Language.LSP.VFS +import Prettyprinter import System.IO data LspServerLog @@ -183,9 +179,9 @@ go (parse parser remainder) parser = do - try contentType <|> (return ()) + try contentType <|> return () len <- contentLength - try contentType <|> (return ()) + try contentType <|> return () _ <- string _ONE_CRLF Attoparsec.take len diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} @@ -5,7 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CUSKs #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -21,7 +21,7 @@ ) import Control.Applicative import Control.Concurrent.Async -import Control.Concurrent.MVar +import Control.Concurrent.Extra as C import Control.Concurrent.STM import Control.Exception qualified as E import Control.Lens (at, (^.), (^?), _Just) @@ -49,7 +49,6 @@ import Data.Maybe import Data.Monoid (Ap (..)) import Data.Ord (Down (Down)) -import Data.Row import Data.Text (Text) import Data.Text qualified as T import Data.UUID qualified as UUID @@ -88,7 +87,7 @@ instance Pretty LspCoreLog where pretty (NewConfig config) = "LSP: set new config:" <+> prettyJSON config - pretty (ConfigurationNotSupported) = "LSP: not requesting configuration since the client does not support workspace/configuration" + pretty ConfigurationNotSupported = "LSP: not requesting configuration since the client does not support workspace/configuration" pretty (ConfigurationParseError settings err) = vsep [ "LSP: configuration parse error:" @@ -97,7 +96,7 @@ , prettyJSON settings ] pretty (BadConfigurationResponse err) = "LSP: error when requesting configuration: " <+> pretty err - pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> (prettyJSON $ J.toJSON sections) + pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> prettyJSON (J.toJSON sections) pretty (CantRegister m) = "LSP: can't register dynamically for:" <+> pretty m newtype LspT config m a = LspT {unLspT :: ReaderT (LanguageContextEnv config) m a} @@ -212,6 +211,10 @@ , resRegistrationsNot :: !(TVar (RegistrationMap Notification)) , resRegistrationsReq :: !(TVar (RegistrationMap Request)) , resLspId :: !(TVar Int32) + , resShutdown :: !(C.Barrier ()) + -- ^ Has the server received 'shutdown'? Can be used to conveniently trigger e.g. thread termination, + -- but if you need a cleanup action to terminate before exiting, then you should install a full + -- 'shutdown' handler } type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) @@ -280,7 +283,7 @@ , optExecuteCommandCommands :: Maybe [Text] -- ^ The commands to be executed on the server. -- If you set `executeCommandHandler`, you **must** set this. - , optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text)) + , optServerInfo :: Maybe ServerInfo -- ^ Information about the server that can be advertised to the client. , optSupportClientInitiatedProgress :: Bool -- ^ Whether or not to support client-initiated progress. @@ -493,7 +496,7 @@ reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath) reverseFileMap = do vfs <- getsState resVFS - let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs + let f fp = Map.findWithDefault fp fp $ reverseMap vfs return f {-# INLINE reverseFileMap #-} @@ -608,7 +611,7 @@ pure (Just $ RegistrationToken method regId) else do - logger <& (CantRegister SMethod_WorkspaceDidChangeConfiguration) `WithSeverity` Warning + logger <& CantRegister SMethod_WorkspaceDidChangeConfiguration `WithSeverity` Warning pure Nothing {- | Sends a @client/unregisterCapability@ request and removes the handler @@ -904,6 +907,25 @@ Left err -> logger <& BadConfigurationResponse err `WithSeverity` Error else logger <& ConfigurationNotSupported `WithSeverity` Debug +-------------------------------------------------------------------------------- +-- CONFIG +-------------------------------------------------------------------------------- + +-- | Checks if the server has received a 'shutdown' request. +isShuttingDown :: (m ~ LspM config) => m Bool +isShuttingDown = do + b <- resShutdown . resState <$> getLspEnv + r <- liftIO $ C.waitBarrierMaybe b + pure $ case r of + Just _ -> True + Nothing -> False + +-- | Blocks until the server receives a 'shutdown' request. +waitShuttingDown :: (m ~ LspM config) => m () +waitShuttingDown = do + b <- resShutdown . resState <$> getLspEnv + liftIO $ C.waitBarrier b + {- Note [LSP configuration] LSP configuration is a huge mess. - The configuration model of the client is not specified @@ -988,4 +1010,21 @@ The 'cancellable' property that we can set when making progress reports just affects whether the client should show a 'Cancel' button to the user in the UI. The client can still always choose to cancel for another reason. +-} + +{- Note [Shutdown] +The 'shutdown' request basically tells the server to clean up and stop doing things. +In particular, it allows us to ignore or reject all further messages apart from 'exit'. + +We also provide a `Barrier` that indicates whether or not we are shutdown, this can +be convenient, e.g. you can race a thread against `waitBarrier` to have it automatically +be cancelled when we receive `shutdown`. + +Shutdown is a request, and the client won't send `exit` until a server responds, so if you +want to be sure that some cleanup happens, you need to ensure we don't respond to `shutdown` +until it's done. The best way to do this is just to install a specific `shutdown` handler. + +After the `shutdown` request, we don't handle any more requests and notifications other than +`exit`. We also don't handle any more responses to requests we have sent but just throw the +responses away. -} diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs --- a/src/Language/LSP/Server/Processing.hs +++ b/src/Language/LSP/Server/Processing.hs @@ -1,12 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TypeInType #-} --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} -- there's just so much! {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -21,6 +17,7 @@ (<&), ) +import Control.Concurrent.Extra as C import Control.Concurrent.STM import Control.Exception qualified as E import Control.Lens hiding (Empty) @@ -50,11 +47,9 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map import Data.Monoid -import Data.Row import Data.String (fromString) import Data.Text qualified as T import Data.Text.Lazy.Encoding qualified as TL -import Data.Text.Prettyprint.Doc import Language.LSP.Protocol.Lens qualified as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -62,6 +57,7 @@ import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap import Language.LSP.Server.Core import Language.LSP.VFS as VFS +import Prettyprinter import System.Exit data LspProcessingLog @@ -70,6 +66,8 @@ | MessageProcessingError BSL.ByteString String | forall m. MissingHandler Bool (SClientMethod m) | ProgressCancel ProgressToken + | forall m. MessageDuringShutdown (SClientMethod m) + | ShuttingDown | Exiting deriving instance Show LspProcessingLog @@ -86,11 +84,14 @@ ] pretty (MissingHandler _ m) = "LSP: no handler for:" <+> pretty m pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> pretty tid - pretty Exiting = "LSP: Got exit, exiting" + pretty (MessageDuringShutdown m) = "LSP: received message during shutdown:" <+> pretty m + pretty ShuttingDown = "LSP: received shutdown" + pretty Exiting = "LSP: received exit" processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> BSL.ByteString -> m () processMessage logger jsonStr = do pendingResponsesVar <- LspT $ asks $ resPendingResponses . resState + shutdown <- isShuttingDown join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do val <- except $ eitherDecode jsonStr pending <- lift $ readTVar pendingResponsesVar @@ -99,8 +100,10 @@ FromClientMess m mess -> pure $ handle logger m mess FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do + -- see Note [Shutdown] writeTVar pendingResponsesVar newMap - pure $ liftIO $ f (res ^. L.result) + unless shutdown <$> do + pure $ liftIO $ f (res ^. L.result) where parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) parser rm = parseClientMessage $ \i -> @@ -123,7 +126,7 @@ sendResp $ makeResponseError (req ^. L.id) err pure Nothing handleErr (Right a) = pure $ Just a - flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo + E.handle (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo let p = req ^. L.params rootDir = getFirst $ @@ -132,7 +135,7 @@ [ p ^? L.rootUri . _L >>= uriToFilePath , p ^? L.rootPath . _Just . _L <&> T.unpack ] - clientCaps = (p ^. L.capabilities) + clientCaps = p ^. L.capabilities let initialWfs = case p ^. L.workspaceFolders of Just (InL xs) -> xs @@ -144,11 +147,11 @@ initialConfig <- case configObject of Just o -> case parseConfig defaultConfig o of Right newConfig -> do - liftIO $ logger <& (LspCore $ NewConfig o) `WithSeverity` Debug + liftIO $ logger <& LspCore (NewConfig o) `WithSeverity` Debug pure newConfig Left err -> do -- Warn not error here, since initializationOptions is pretty unspecified - liftIO $ logger <& (LspCore $ ConfigurationParseError o err) `WithSeverity` Warning + liftIO $ logger <& LspCore (ConfigurationParseError o err) `WithSeverity` Warning pure defaultConfig Nothing -> pure defaultConfig @@ -165,6 +168,7 @@ resRegistrationsNot <- newTVarIO mempty resRegistrationsReq <- newTVarIO mempty resLspId <- newTVarIO 0 + resShutdown <- C.newBarrier pure LanguageContextState{..} -- Call the 'duringInitialization' callback to let the server kick stuff up @@ -388,14 +392,14 @@ | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True | otherwise = Nothing semanticTokenFullProvider - | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ #delta .== supported SMethod_TextDocumentSemanticTokensFullDelta + | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ SemanticTokensFullDelta{_delta = supported SMethod_TextDocumentSemanticTokensFullDelta} | otherwise = Nothing sync = case optTextDocumentSync o of Just x -> Just (InL x) Nothing -> Nothing - workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing + workspace = WorkspaceOptions{_workspaceFolders = workspaceFolder, _fileOperations = Nothing} workspaceFolder = supported' SMethod_WorkspaceDidChangeWorkspaceFolders $ -- sign up to receive notifications @@ -415,13 +419,21 @@ {- | Invokes the registered dynamic or static handlers for the given message and method, as well as doing some bookkeeping. -} -handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m () +handle :: forall m config meth. (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m () handle logger m msg = case m of 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 $ \_ -> initialDynamicRegistrations logger >> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg + SMethod_Shutdown -> handle' logger (Just $ \_ -> signalShutdown) m msg + where + -- See Note [Shutdown] + signalShutdown :: LspM config () + signalShutdown = do + logger <& ShuttingDown `WithSeverity` Info + b <- resShutdown . resState <$> getLspEnv + liftIO $ signalBarrier b () 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 @@ -439,55 +451,53 @@ TClientMessage meth -> m () handle' logger mAction m msg = do - maybe (return ()) (\f -> f msg) mAction + shutdown <- isShuttingDown + -- These are the methods that we are allowed to process during shutdown. + -- The reason that we do not include 'shutdown' itself here is because + -- by the time we get the first 'shutdown' message, isShuttingDown will + -- still be false, so we would still be able to process it. + -- This ensures we won't process the second 'shutdown' message and only + -- process 'exit' during shutdown. + let allowedMethod m = case (splitClientMethod m, m) of + (IsClientNot, SMethod_Exit) -> True + _ -> False + case mAction of + Just f | not shutdown || allowedMethod m -> f msg + _ -> pure () + dynReqHandlers <- getsState resRegistrationsReq dynNotHandlers <- getsState resRegistrationsNot env <- getLspEnv let Handlers{reqHandlers, notHandlers} = resHandlers env - let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> IO () - mkRspCb req (Left err) = - runLspT env $ - sendToClient $ - FromServerRsp (req ^. L.method) $ - TResponseMessage "2.0" (Just (req ^. L.id)) (Left err) - mkRspCb req (Right rsp) = - runLspT env $ - sendToClient $ - FromServerRsp (req ^. L.method) $ - TResponseMessage "2.0" (Just (req ^. L.id)) (Right rsp) - case splitClientMethod m of + -- See Note [Shutdown] + IsClientNot | shutdown, not (allowedMethod m) -> notificationDuringShutdown IsClientNot -> case pickHandler dynNotHandlers notHandlers of Just h -> liftIO $ h msg Nothing | SMethod_Exit <- m -> exitNotificationHandler logger msg - | otherwise -> do - reportMissingHandler + | otherwise -> missingNotificationHandler + -- See Note [Shutdown] + IsClientReq | shutdown, not (allowedMethod m) -> requestDuringShutdown msg IsClientReq -> case pickHandler dynReqHandlers reqHandlers of - Just h -> liftIO $ h msg (mkRspCb msg) + Just h -> liftIO $ h msg (runLspT env . sendResponse msg) Nothing - | SMethod_Shutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) - | otherwise -> do - let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] - err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing - sendToClient $ - FromServerRsp (msg ^. L.method) $ - TResponseMessage "2.0" (Just (msg ^. L.id)) (Left err) + | SMethod_Shutdown <- m -> liftIO $ shutdownRequestHandler msg (runLspT env . sendResponse msg) + | otherwise -> missingRequestHandler msg IsClientEither -> case msg of + -- See Note [Shutdown] + NotMess _ | shutdown -> notificationDuringShutdown NotMess noti -> case pickHandler dynNotHandlers notHandlers of Just h -> liftIO $ h noti - Nothing -> reportMissingHandler + Nothing -> missingNotificationHandler + -- See Note [Shutdown] + ReqMess req | shutdown -> requestDuringShutdown req ReqMess req -> case pickHandler dynReqHandlers reqHandlers of - Just h -> liftIO $ h req (mkRspCb req) - Nothing -> do - let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] - err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing - sendToClient $ - FromServerRsp (req ^. L.method) $ - TResponseMessage "2.0" (Just (req ^. L.id)) (Left err) + Just h -> liftIO $ h req (runLspT env . sendResponse req) + Nothing -> missingRequestHandler req where -- \| Checks to see if there's a dynamic handler, and uses it in favour of the -- static handler, if it exists. @@ -497,13 +507,31 @@ (Nothing, Just (ClientMessageHandler h)) -> Just h (Nothing, Nothing) -> Nothing + sendResponse :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> m () + sendResponse req res = sendToClient $ FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) res + + requestDuringShutdown :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> m () + requestDuringShutdown req = do + logger <& MessageDuringShutdown m `WithSeverity` Warning + sendResponse req (Left (ResponseError (InR ErrorCodes_InvalidRequest) "Server is shutdown" Nothing)) + + notificationDuringShutdown :: m () + notificationDuringShutdown = logger <& MessageDuringShutdown m `WithSeverity` Warning + -- '$/' notifications should/could be ignored by server. -- Don't log errors in that case. -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. - reportMissingHandler :: m () - reportMissingHandler = + missingNotificationHandler :: m () + missingNotificationHandler = let optional = isOptionalMethod (SomeMethod m) in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error + + missingRequestHandler :: TRequestMessage (m1 :: Method ClientToServer Request) -> m () + missingRequestHandler req = do + logger <& MissingHandler False m `WithSeverity` Error + let errorMsg = T.pack $ unwords ["No handler for: ", show m] + err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing + sendResponse req (Left err) progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m () progressCancelHandler logger (TNotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do diff --git a/src/Language/LSP/VFS.hs b/src/Language/LSP/VFS.hs --- a/src/Language/LSP/VFS.hs +++ b/src/Language/LSP/VFS.hs @@ -1,14 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE ViewPatterns #-} --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} {- | Handles the "Language.LSP.Types.TextDocumentDidChange" \/ @@ -67,17 +64,16 @@ import Data.List import Data.Map.Strict qualified as Map import Data.Ord -import Data.Row import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T -import Data.Text.Prettyprint.Doc hiding (line) import Data.Text.Utf16.Lines as Utf16 (Position (..)) import Data.Text.Utf16.Rope.Mixed (Rope) import Data.Text.Utf16.Rope.Mixed qualified as Rope import Language.LSP.Protocol.Lens qualified as J import Language.LSP.Protocol.Message qualified as J import Language.LSP.Protocol.Types qualified as J +import Prettyprinter hiding (line) import System.Directory import System.FilePath import System.IO @@ -250,8 +246,8 @@ editRange (J.InL e) = e ^. J.range editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent - editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText - editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText + editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent $ J.InL $ J.TextDocumentContentChangePartial{_range = e ^. J.range, _rangeLength = Nothing, _text = e ^. J.newText} + editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ J.TextDocumentContentChangePartial{_range = e ^. J.range, _rangeLength = Nothing, _text = e ^. J.newText} applyDocumentChange :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DocumentChange -> m () applyDocumentChange logger (J.InL change) = applyTextDocumentEdit logger change @@ -338,11 +334,11 @@ applyChange :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> J.TextDocumentContentChangeEvent -> m Rope applyChange logger str (J.TextDocumentContentChangeEvent (J.InL e)) - | J.Range (J.Position sl sc) (J.Position fl fc) <- e .! #range - , txt <- e .! #text = + | J.Range (J.Position sl sc) (J.Position fl fc) <- e ^. J.range + , txt <- e ^. J.text = changeChars logger str (Utf16.Position (fromIntegral sl) (fromIntegral sc)) (Utf16.Position (fromIntegral fl) (fromIntegral fc)) txt applyChange _ _ (J.TextDocumentContentChangeEvent (J.InR e)) = - pure $ Rope.fromText $ e .! #text + pure $ Rope.fromText $ e ^. J.text -- --------------------------------------------------------------------- diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module VspSpec where -import Data.Row import Data.String import Data.Text qualified as T import Data.Text.Utf16.Rope.Mixed qualified as Rope @@ -35,7 +34,7 @@ -- --------------------------------------------------------------------- mkChangeEvent :: J.Range -> T.Text -> J.TextDocumentContentChangeEvent -mkChangeEvent r t = J.TextDocumentContentChangeEvent $ J.InL $ #range .== r .+ #rangeLength .== Nothing .+ #text .== t +mkChangeEvent r t = J.TextDocumentContentChangeEvent $ J.InL $ J.TextDocumentContentChangePartial{J._range = r, J._rangeLength = Nothing, J._text = t} vspSpec :: Spec vspSpec = do