lsp 2.4.0.0 → 2.5.0.0
raw patch · 10 files changed
+161/−93 lines, 10 filesdep +extradep −row-typesdep ~lsp-types
Dependencies added: extra
Dependencies removed: row-types
Dependency ranges changed: lsp-types
Files
- ChangeLog.md +6/−0
- example/Reactor.hs +2/−5
- lsp.cabal +12/−9
- src/Language/LSP/Diagnostics.hs +1/−1
- src/Language/LSP/Server.hs +4/−0
- src/Language/LSP/Server/Control.hs +3/−7
- src/Language/LSP/Server/Core.hs +47/−8
- src/Language/LSP/Server/Processing.hs +77/−49
- src/Language/LSP/VFS.hs +7/−11
- test/VspSpec.hs +2/−3
ChangeLog.md view
@@ -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
example/Reactor.hs view
@@ -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
lsp.cabal view
@@ -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
src/Language/LSP/Diagnostics.hs view
@@ -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 -- ---------------------------------------------------------------------
src/Language/LSP/Server.hs view
@@ -35,6 +35,10 @@ requestConfigUpdate, tryChangeConfig, + -- * Shutdown+ isShuttingDown,+ waitShuttingDown,+ -- * VFS getVirtualFile, getVirtualFiles,
src/Language/LSP/Server/Control.hs view
@@ -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
src/Language/LSP/Server/Core.hs view
@@ -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. -}
src/Language/LSP/Server/Processing.hs view
@@ -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
src/Language/LSP/VFS.hs view
@@ -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 -- ---------------------------------------------------------------------
test/VspSpec.hs view
@@ -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