diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,19 @@ # Revision history for lsp +## 2.4.0.0 + +- Server-created progress now will not send reports until and unless the client + confirms the progress token creation. +- Progress helper functions now can take a progress token provided by the client, + so client-initiated progress can now be supported properly. +- The server options now allow the user to say whether the server should advertise + support for client-initiated progress or not. +- The server now dynamically registers for `workspace/didChangeConfiguration` + notifications, to ensure that newer clients continue to send them. +- Removed `getCompletionPrefix` from the `VFS` module. This is specific to completing + Haskell identifiers and doesn't belong here. It has already been moved to `ghcide` + some time ago. + ## 2.3.0.0 - Fix inference of server capabilities for newer methods (except notebook methods). diff --git a/example/Reactor.hs b/example/Reactor.hs --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -1,11 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. @@ -221,11 +218,16 @@ let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do - logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info - let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing - rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right $ LSP.InL rsp) + void + $ registerCapability + mempty + LSP.SMethod_TextDocumentCodeLens + regOpts + $ \_req responder -> do + logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info + let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing + rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right $ LSP.InL rsp) , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri fileName = LSP.uriToFilePath doc @@ -313,7 +315,7 @@ logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request - void $ withProgress "Executing some long running command" Cancellable $ \update -> + void $ withProgress "Executing some long running command" (req ^. LSP.params . LSP.workDoneToken) Cancellable $ \update -> forM [(0 :: LSP.UInt) .. 10] $ \i -> do update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) liftIO $ threadDelay (1 * 1000000) diff --git a/example/Simple.hs b/example/Simple.hs --- a/example/Simple.hs +++ b/example/Simple.hs @@ -21,7 +21,7 @@ Right (InL (MessageActionItem "Turn on")) -> do let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False) - _ <- registerCapability SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do + _ <- registerCapability mempty SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] responder $ Right $ InL rsp 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.3.0.0 +version: 2.4.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -28,10 +28,8 @@ library hs-source-dirs: src - default-language: Haskell2010 - default-extensions: ImportQualifiedPost + default-language: GHC2021 ghc-options: -Wall -fprint-explicit-kinds - reexported-modules: , Language.LSP.Protocol.Types , Language.LSP.Protocol.Lens @@ -51,45 +49,44 @@ ghc-options: -Wall build-depends: - , aeson >=1.0.0.0 - , async >=2.0 - , attoparsec - , base >=4.11 && <5 - , bytestring - , co-log-core >=0.3.1.0 - , containers - , data-default - , directory - , exceptions - , filepath - , hashable - , lens-aeson - , lens >=4.15.2 + , aeson >=2 && <2.3 + , async ^>=2.2 + , attoparsec ^>=0.14 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.13 + , co-log-core ^>=0.3 + , containers ^>=0.6 + , data-default ^>=0.7 + , directory ^>=1.3 + , exceptions ^>=0.10 + , filepath >=1.4 && < 1.6 + , hashable ^>=1.4 + , lens >=5.1 && <5.3 + , lens-aeson ^>=1.2 , lsp-types ^>=2.1 - , mtl <2.4 - , prettyprinter - , random - , row-types + , mtl >=2.2 && <2.4 + , prettyprinter ^>=1.7 + , random ^>=1.2 + , row-types ^>=1.0 , sorted-list ^>=0.2.1 , stm ^>=2.5 - , text - , text-rope - , transformers >=0.5.6 && <0.7 - , unliftio-core >=0.2.0.0 - , unordered-containers + , text >=1 && <2.2 + , text-rope ^>=0.2 + , transformers >=0.5 && <0.7 + , unliftio-core ^>=0.2 + , unordered-containers ^>=0.2 , uuid >=1.3 executable lsp-demo-reactor-server - main-is: Reactor.hs - hs-source-dirs: example - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - ghc-options: -Wall -Wno-unticked-promoted-constructors + main-is: Reactor.hs + hs-source-dirs: example + default-language: GHC2021 + ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , aeson , base , co-log-core - , lens >=4.15.2 + , lens , lsp , prettyprinter , stm @@ -100,11 +97,10 @@ buildable: False executable lsp-demo-simple-server - main-is: Simple.hs - hs-source-dirs: example - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - ghc-options: -Wall -Wno-unticked-promoted-constructors + main-is: Simple.hs + hs-source-dirs: example + default-language: GHC2021 + ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , base , lsp @@ -133,12 +129,11 @@ , hspec , lsp , row-types - , sorted-list >=0.2.1 && <0.2.2 + , sorted-list , text , text-rope , unordered-containers build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - default-language: Haskell2010 - default-extensions: ImportQualifiedPost + 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 @@ -1,6 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {- 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExplicitNamespaces #-} module Language.LSP.Server ( module Language.LSP.Server.Control, 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,7 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} 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,20 +1,13 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CUSKs #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} @@ -26,7 +19,9 @@ WithSeverity (..), (<&), ) +import Control.Applicative import Control.Concurrent.Async +import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception qualified as E import Control.Lens (at, (^.), (^?), _Just) @@ -68,7 +63,7 @@ import Language.LSP.Protocol.Utils.Misc (prettyJSON) import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap -import Language.LSP.VFS +import Language.LSP.VFS hiding (end) import Prettyprinter import System.Random hiding (next) @@ -87,8 +82,10 @@ | ConfigurationNotSupported | BadConfigurationResponse ResponseError | WrongConfigSections [J.Value] - deriving (Show) + | forall m. CantRegister (SMethod m) +deriving instance (Show LspCoreLog) + 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" @@ -101,6 +98,7 @@ ] 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 (CantRegister m) = "LSP: can't register dynamically for:" <+> pretty m newtype LspT config m a = LspT {unLspT :: ReaderT (LanguageContextEnv config) m a} deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix) @@ -284,6 +282,8 @@ -- If you set `executeCommandHandler`, you **must** set this. , optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text)) -- ^ Information about the server that can be advertised to the client. + , optSupportClientInitiatedProgress :: Bool + -- ^ Whether or not to support client-initiated progress. } instance Default Options where @@ -298,6 +298,7 @@ Nothing Nothing Nothing + False defaultOptions :: Options defaultOptions = def @@ -552,30 +553,27 @@ registerCapability :: forall f t (m :: Method ClientToServer t) config. MonadLsp config f => + LogAction f (WithSeverity LspCoreLog) -> SClientMethod m -> RegistrationOptions m -> Handler f m -> f (Maybe (RegistrationToken m)) -registerCapability method regOpts f = do - clientCaps <- resClientCapabilities <$> getLspEnv +registerCapability logger method regOpts f = do 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 logger 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)) @@ -585,12 +583,34 @@ 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 => + LogAction f (WithSeverity LspCoreLog) -> + SClientMethod m -> + RegistrationOptions m -> + f (Maybe (RegistrationToken m)) +trySendRegistration logger 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 do + logger <& (CantRegister SMethod_WorkspaceDidChangeConfiguration) `WithSeverity` Warning + pure Nothing + {- | Sends a @client/unregisterCapability@ request and removes the handler for that associated registration. -} @@ -625,98 +645,163 @@ in (L.ProgressToken $ L.InL cur, next) {-# INLINE getNewProgressId #-} -withProgressBase :: MonadLsp c m => Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a -withProgressBase indefinite title cancellable f = do - progId <- getNewProgressId +{- | The progress states we can be in. +See Note [Progress states] +-} +data ProgressState = ProgressInitial | ProgressStarted ProgressToken | ProgressEnded - let initialPercentage - | indefinite = Nothing - | otherwise = Just 0 - cancellable' = case cancellable of - Cancellable -> True - NotCancellable -> False +withProgressBase :: + forall c m a. + MonadLsp c m => + Bool -> + Text -> + Maybe ProgressToken -> + ProgressCancellable -> + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgressBase indefinite title clientToken cancellable f = do + progressState <- liftIO $ newMVar ProgressInitial - -- Create progress token - -- FIXME : This needs to wait until the request returns before - -- continuing!!! - _ <- sendRequest - SMethod_WindowWorkDoneProgressCreate - (WorkDoneProgressCreateParams progId) - $ \res -> do - case res of - -- An error occurred when the client was setting it up - -- No need to do anything then, as per the spec - Left _err -> pure () - Right _ -> pure () + -- Until we start the progress reporting, track the current latest progress in an MVar, so when + -- we do start we can start at the right point. + let initialPercentage = if indefinite then Nothing else Just 0 + initialProgress <- liftIO $ newMVar (ProgressAmount initialPercentage Nothing) - -- Send the begin and done notifications via 'bracket_' so that they are always fired - res <- withRunInIO $ \runInBase -> - E.bracket_ - -- Send begin notification - ( runInBase $ - sendNotification SMethod_Progress $ - ProgressParams progId $ - J.toJSON $ - WorkDoneProgressBegin L.AString title (Just cancellable') Nothing initialPercentage - ) - -- Send end notification - ( runInBase $ - sendNotification SMethod_Progress $ - ProgressParams progId $ - J.toJSON $ - (WorkDoneProgressEnd L.AString Nothing) - ) - $ do - -- Run f asynchronously - aid <- async $ runInBase $ f (updater progId) - runInBase $ storeProgress progId aid - wait aid + let + sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m () + sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report - -- Delete the progress cancellation from the map - -- If we don't do this then it's easy to leak things as the map contains any IO action. - deleteProgress progId + -- See Note [Progress states] + tryStart :: ProgressToken -> m () + tryStart t = withRunInIO $ \runInBase -> modifyMVar_ progressState $ \case + -- Can start if we are in the initial state, otherwise not + ProgressInitial -> withMVar initialProgress $ \(ProgressAmount pct msg) -> do + let + cancellable' = case cancellable of + Cancellable -> Just True + NotCancellable -> Just False + runInBase $ sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct + pure (ProgressStarted t) + s -> pure s + -- See Note [Progress states] + tryUpdate :: ProgressAmount -> m () + tryUpdate (ProgressAmount pct msg) = withRunInIO $ \runInBase -> withMVar progressState $ \case + -- If the progress has not started yet, then record the latest progress percentage + ProgressInitial -> modifyMVar_ initialProgress $ \(ProgressAmount oldPct oldMsg) -> do + let + -- Update the percentage if the new one is not nothing + newPct = pct <|> oldPct + -- Update the message if the new one is not nothing + newMsg = msg <|> oldMsg + pure $ ProgressAmount newPct newMsg + -- Just send the update, we don't need to worry about updating initialProgress any more + ProgressStarted t -> runInBase $ sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct + _ -> pure () + -- See Note [Progress states] + tryEnd :: m () + tryEnd = withRunInIO $ \runInBase -> modifyMVar_ progressState $ \case + -- Don't send an end message unless we successfully started + ProgressStarted t -> do + runInBase $ sendProgressReport t $ WorkDoneProgressEnd L.AString Nothing + pure ProgressEnded + -- But in all cases we still want to transition state + _ -> pure ProgressEnded - return res - where - updater progId (ProgressAmount percentage msg) = do - sendNotification SMethod_Progress $ - ProgressParams progId $ - J.toJSON $ - WorkDoneProgressReport L.AString Nothing msg percentage + -- The progress token is also used as the cancellation ID + -- See Note [Request cancellation] + createAndStart :: m ProgressToken + createAndStart = + case clientToken of + -- See Note [Client- versus server-initiated progress] + -- Client-initiated progress + Just t -> tryStart t >> pure t + -- Try server-initiated progress + Nothing -> do + t <- getNewProgressId + clientCaps <- getClientCapabilities -clientSupportsProgress :: L.ClientCapabilities -> Bool -clientSupportsProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just -{-# INLINE clientSupportsProgress #-} + -- If we don't have a progress token from the client and + -- the client doesn't support server-initiated progress then + -- there's nothing to do: we can't report progress. + -- But we still need to return our internal token to use for + -- cancellation + when (clientSupportsServerInitiatedProgress clientCaps) + $ void + $ + -- Server-initiated progress + -- See Note [Client- versus server-initiated progress] + sendRequest + SMethod_WindowWorkDoneProgressCreate + (WorkDoneProgressCreateParams t) + $ \case + -- Successfully registered the token, we can now use it. + -- So we go ahead and start. We do this as soon as we get the + -- token back so the client gets feedback ASAP + Right _ -> tryStart t + -- The client sent us an error, we can't use the token. So we remain + -- in ProgressInitial and don't send any progress updates ever + -- TODO: log the error + Left _err -> pure () -{- | Wrapper for reporting progress to the client during a long running - task. - 'withProgress' @title cancellable f@ starts a new progress reporting - session, and finishes it once f is completed. - f is provided with an update function that allows it to report on - the progress during the session. - If @cancellable@ is 'Cancellable', @f@ will be thrown a - 'ProgressCancelledException' if the user cancels the action in - progress. --} -withProgress :: MonadLsp c m => Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a -withProgress title cancellable f = do - clientCaps <- getClientCapabilities - if clientSupportsProgress clientCaps - then withProgressBase False title cancellable f - else f (const $ return ()) + pure t -{- | Same as 'withProgress', but for processes that do not report the - precentage complete. + end :: ProgressToken -> m () + end cancellationId = do + tryEnd + -- Delete the progress cancellation from the map + -- If we don't do this then it's easy to leak things as the map contains any IO action. + deleteProgress cancellationId - @since 0.10.0.0 + -- Send the begin and done notifications via 'bracket' so that they are always fired + withRunInIO $ \runInBase -> + E.bracket (runInBase createAndStart) (runInBase . end) $ \cancellationId -> do + -- Run f asynchronously + aid <- async $ runInBase $ f tryUpdate + -- Always store the thread ID so we can cancel, see Note [Request cancellation] + runInBase $ storeProgress cancellationId aid + wait aid + +clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool +clientSupportsServerInitiatedProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just +{-# INLINE clientSupportsServerInitiatedProgress #-} + +{- | +Wrapper for reporting progress to the client during a long running task. -} -withIndefiniteProgress :: MonadLsp c m => Text -> ProgressCancellable -> m a -> m a -withIndefiniteProgress title cancellable f = do - clientCaps <- getClientCapabilities - if clientSupportsProgress clientCaps - then withProgressBase True title cancellable (const f) - else f +withProgress :: + MonadLsp c m => + -- | The title of the progress operation + Text -> + -- | The progress token provided by the client in the method params, if any + Maybe ProgressToken -> + -- | Whether or not this operation is cancellable. If true, the user will be + -- shown a button to allow cancellation. Note that requests can still be cancelled + -- even if this is not set. + ProgressCancellable -> + -- | An update function to pass progress updates to + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgress title clientToken cancellable f = withProgressBase False title clientToken cancellable f +{- | +Same as 'withProgress', but for processes that do not report the precentage complete. +-} +withIndefiniteProgress :: + MonadLsp c m => + -- | The title of the progress operation + Text -> + -- | The progress token provided by the client in the method params, if any + Maybe ProgressToken -> + -- | Whether or not this operation is cancellable. If true, the user will be + -- shown a button to allow cancellation. Note that requests can still be cancelled + -- even if this is not set. + ProgressCancellable -> + -- | An update function to pass progress updates to + ((Text -> m ()) -> m a) -> + m a +withIndefiniteProgress title clientToken cancellable f = + withProgressBase True title clientToken cancellable (\update -> f (\msg -> update (ProgressAmount Nothing (Just msg)))) + -- --------------------------------------------------------------------- {- | Aggregate all diagnostics pertaining to a particular version of a document, @@ -865,4 +950,42 @@ try to parse the entire config object. This hopefully lets us handle a variety of sensible cases where the client sends us mostly our config, either wrapped in our section or not. +-} + +{- Note [Progress states] +Creating and using progress actually requires a small state machine. +The states are: +- ProgressInitial: we haven't got a progress token +- ProgressStarted: we have got a progress token and started the progress +- ProgressEnded: we have ended the progress + +Notably, +1. We can't send updates except in ProgressStarted +2. We can't start the progress until we get the token back + - This means that we may have to wait to send the start report, we can't necessarily + send it immediately! +3. We can end if we haven't started (by just transitioning state), but we shouldn't + send an end report. + +We can have concurrent updates to the state, since we sometimes transiton states +in response to the client. In particular, for server-initiated progress, we have +to wait for the client to confirm the token until we can enter ProgressStarted. +-} + +{- Note [Client- versus server-initiated progress] +The protocol supports both client- and server-initiated progress. Client-initiated progress +is simpler: the client gives you a progress token, and then you use that to report progress. +Server-initiated progress is more complex: you need to send a request to the client to tell +them about the token you want to use, and only after that can you send updates using it. +-} + +{- Note [Request cancellation] +Request cancellation is a bit strange. + +We need to in fact assume that all requests are cancellable, see +https://github.com/microsoft/language-server-protocol/issues/1159. + +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. -} 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,15 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeInType #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. @@ -56,7 +49,6 @@ import Data.List import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map -import Data.Maybe import Data.Monoid import Data.Row import Data.String (fromString) @@ -201,42 +193,93 @@ static option. -} inferServerCapabilities :: ClientCapabilities -> Options -> Handlers m -> ServerCapabilities -inferServerCapabilities clientCaps o h = +inferServerCapabilities _clientCaps o h = ServerCapabilities { _textDocumentSync = sync - , _hoverProvider = supportedBool SMethod_TextDocumentHover + , _hoverProvider = + supported' SMethod_TextDocumentHover $ + InR $ + HoverOptions clientInitiatedProgress , _completionProvider = completionProvider , _inlayHintProvider = inlayProvider - , _declarationProvider = supportedBool SMethod_TextDocumentDeclaration + , _declarationProvider = + supported' SMethod_TextDocumentDeclaration $ + InR $ + InL $ + DeclarationOptions clientInitiatedProgress , _signatureHelpProvider = signatureHelpProvider - , _definitionProvider = supportedBool SMethod_TextDocumentDefinition - , _typeDefinitionProvider = supportedBool SMethod_TextDocumentTypeDefinition - , _implementationProvider = supportedBool SMethod_TextDocumentImplementation - , _referencesProvider = supportedBool SMethod_TextDocumentReferences - , _documentHighlightProvider = supportedBool SMethod_TextDocumentDocumentHighlight - , _documentSymbolProvider = supportedBool SMethod_TextDocumentDocumentSymbol + , _definitionProvider = + supported' SMethod_TextDocumentDefinition $ + InR $ + DefinitionOptions clientInitiatedProgress + , _typeDefinitionProvider = + supported' SMethod_TextDocumentTypeDefinition $ + InR $ + InL $ + TypeDefinitionOptions clientInitiatedProgress + , _implementationProvider = + supported' SMethod_TextDocumentImplementation $ + InR $ + InL $ + ImplementationOptions clientInitiatedProgress + , _referencesProvider = + supported' SMethod_TextDocumentReferences $ + InR $ + ReferenceOptions clientInitiatedProgress + , _documentHighlightProvider = + supported' SMethod_TextDocumentDocumentHighlight $ + InR $ + DocumentHighlightOptions clientInitiatedProgress + , _documentSymbolProvider = + supported' SMethod_TextDocumentDocumentSymbol $ + InR $ + DocumentSymbolOptions clientInitiatedProgress Nothing , _codeActionProvider = codeActionProvider , _codeLensProvider = supported' SMethod_TextDocumentCodeLens $ - CodeLensOptions - (Just False) - (supported SMethod_CodeLensResolve) - , _documentFormattingProvider = supportedBool SMethod_TextDocumentFormatting - , _documentRangeFormattingProvider = supportedBool SMethod_TextDocumentRangeFormatting + CodeLensOptions clientInitiatedProgress (supported SMethod_CodeLensResolve) + , _documentFormattingProvider = + supported' SMethod_TextDocumentFormatting $ + InR $ + DocumentFormattingOptions clientInitiatedProgress + , _documentRangeFormattingProvider = + supported' SMethod_TextDocumentRangeFormatting $ + InR $ + DocumentRangeFormattingOptions clientInitiatedProgress , _documentOnTypeFormattingProvider = documentOnTypeFormattingProvider - , _renameProvider = renameProvider + , _renameProvider = + supported' SMethod_TextDocumentRename $ + InR $ + RenameOptions clientInitiatedProgress (supported SMethod_TextDocumentPrepareRename) , _documentLinkProvider = supported' SMethod_TextDocumentDocumentLink $ - DocumentLinkOptions - (Just False) - (supported SMethod_DocumentLinkResolve) - , _colorProvider = supportedBool SMethod_TextDocumentDocumentColor - , _foldingRangeProvider = supportedBool SMethod_TextDocumentFoldingRange + DocumentLinkOptions clientInitiatedProgress (supported SMethod_DocumentLinkResolve) + , _colorProvider = + supported' SMethod_TextDocumentDocumentColor $ + InR $ + InL $ + DocumentColorOptions clientInitiatedProgress + , _foldingRangeProvider = + supported' SMethod_TextDocumentFoldingRange $ + InR $ + InL $ + FoldingRangeOptions clientInitiatedProgress , _executeCommandProvider = executeCommandProvider - , _selectionRangeProvider = supportedBool SMethod_TextDocumentSelectionRange - , _callHierarchyProvider = supportedBool SMethod_TextDocumentPrepareCallHierarchy + , _selectionRangeProvider = + supported' SMethod_TextDocumentSelectionRange $ + InR $ + InL $ + SelectionRangeOptions clientInitiatedProgress + , _callHierarchyProvider = + supported' SMethod_TextDocumentPrepareCallHierarchy $ + InR $ + InL $ + CallHierarchyOptions clientInitiatedProgress , _semanticTokensProvider = semanticTokensProvider - , _workspaceSymbolProvider = supportedBool SMethod_WorkspaceSymbol + , _workspaceSymbolProvider = + supported' SMethod_WorkspaceSymbol $ + InR $ + WorkspaceSymbolOptions clientInitiatedProgress (supported SMethod_WorkspaceSymbolResolve) , _workspace = Just workspace , _experimental = Nothing :: Maybe Value , -- The only encoding the VFS supports is the legacy UTF16 option at the moment @@ -245,30 +288,28 @@ supported' SMethod_TextDocumentLinkedEditingRange $ InR $ InL $ - LinkedEditingRangeOptions{_workDoneProgress = Nothing} + LinkedEditingRangeOptions clientInitiatedProgress , _monikerProvider = supported' SMethod_TextDocumentMoniker $ InR $ InL $ - MonikerOptions{_workDoneProgress = Nothing} + MonikerOptions clientInitiatedProgress , _typeHierarchyProvider = supported' SMethod_TextDocumentPrepareTypeHierarchy $ InR $ InL $ - TypeHierarchyOptions{_workDoneProgress = Nothing} + TypeHierarchyOptions clientInitiatedProgress , _inlineValueProvider = supported' SMethod_TextDocumentInlineValue $ InR $ InL $ - InlineValueOptions{_workDoneProgress = Nothing} + InlineValueOptions clientInitiatedProgress , _diagnosticProvider = diagnosticProvider , -- TODO: super unclear what to do about notebooks in general _notebookDocumentSync = Nothing } where - -- \| For when we just return a simple @true@/@false@ to indicate if we - -- support the capability - supportedBool = Just . InL . supported_b + clientInitiatedProgress = Just (optSupportClientInitiatedProgress o) supported' m b | supported_b m = Just b @@ -286,56 +327,40 @@ singleton :: a -> [a] singleton x = [x] - completionProvider - | supported_b SMethod_TextDocumentCompletion = - Just $ - CompletionOptions - { _triggerCharacters = map T.singleton <$> optCompletionTriggerCharacters o - , _allCommitCharacters = map T.singleton <$> optCompletionAllCommitCharacters o - , _resolveProvider = supported SMethod_CompletionItemResolve - , _completionItem = Nothing - , _workDoneProgress = Nothing - } - | otherwise = Nothing - - inlayProvider - | supported_b SMethod_TextDocumentInlayHint = - Just $ - InR $ - InL - InlayHintOptions - { _workDoneProgress = Nothing - , _resolveProvider = supported SMethod_InlayHintResolve - } - | otherwise = Nothing - - clientSupportsCodeActionKinds = - isJust $ - clientCaps ^? L.textDocument . _Just . L.codeAction . _Just . L.codeActionLiteralSupport . _Just + completionProvider = + supported' SMethod_TextDocumentCompletion $ + CompletionOptions + { _triggerCharacters = map T.singleton <$> optCompletionTriggerCharacters o + , _allCommitCharacters = map T.singleton <$> optCompletionAllCommitCharacters o + , _resolveProvider = supported SMethod_CompletionItemResolve + , _completionItem = Nothing + , _workDoneProgress = clientInitiatedProgress + } - codeActionProvider - | supported_b SMethod_TextDocumentCodeAction = - Just $ - InR $ - CodeActionOptions - { _workDoneProgress = Nothing - , _codeActionKinds = codeActionKinds (optCodeActionKinds o) - , _resolveProvider = supported SMethod_CodeActionResolve - } - | otherwise = Just (InL False) + inlayProvider = + supported' SMethod_TextDocumentInlayHint $ + InR $ + InL + InlayHintOptions + { _workDoneProgress = clientInitiatedProgress + , _resolveProvider = supported SMethod_InlayHintResolve + } - codeActionKinds (Just ks) - | clientSupportsCodeActionKinds = Just ks - codeActionKinds _ = Nothing + codeActionProvider = + supported' SMethod_TextDocumentCodeAction $ + InR $ + CodeActionOptions + { _workDoneProgress = clientInitiatedProgress + , _codeActionKinds = optCodeActionKinds o + , _resolveProvider = supported SMethod_CodeActionResolve + } - signatureHelpProvider - | supported_b SMethod_TextDocumentSignatureHelp = - Just $ - SignatureHelpOptions - Nothing - (map T.singleton <$> optSignatureHelpTriggerCharacters o) - (map T.singleton <$> optSignatureHelpRetriggerCharacters o) - | otherwise = Nothing + signatureHelpProvider = + supported' SMethod_TextDocumentSignatureHelp $ + SignatureHelpOptions + clientInitiatedProgress + (map T.singleton <$> optSignatureHelpTriggerCharacters o) + (map T.singleton <$> optSignatureHelpRetriggerCharacters o) documentOnTypeFormattingProvider | supported_b SMethod_TextDocumentOnTypeFormatting @@ -347,32 +372,18 @@ error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" | otherwise = Nothing - executeCommandProvider - | supported_b SMethod_WorkspaceExecuteCommand - , Just cmds <- optExecuteCommandCommands o = - Just (ExecuteCommandOptions Nothing cmds) - | supported_b SMethod_WorkspaceExecuteCommand - , Nothing <- optExecuteCommandCommands o = - error "executeCommandCommands needs to be set if a executeCommandHandler is set" - | otherwise = Nothing - - clientSupportsPrepareRename = - fromMaybe False $ - clientCaps ^? L.textDocument . _Just . L.rename . _Just . L.prepareSupport . _Just - - renameProvider - | clientSupportsPrepareRename - , supported_b SMethod_TextDocumentRename - , supported_b SMethod_TextDocumentPrepareRename = - Just $ - InR . RenameOptions Nothing . Just $ - True - | supported_b SMethod_TextDocumentRename = Just (InL True) - | otherwise = Just (InL False) + executeCommandProvider = + supported' SMethod_WorkspaceExecuteCommand $ + case optExecuteCommandCommands o of + Just cmds -> ExecuteCommandOptions clientInitiatedProgress cmds + Nothing -> error "executeCommandCommands needs to be set if a executeCommandHandler is set" -- Always provide the default legend -- TODO: allow user-provided legend via 'Options', or at least user-provided types - semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider + semanticTokensProvider = + Just $ + InL $ + SemanticTokensOptions clientInitiatedProgress defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider semanticTokenRangeProvider | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True | otherwise = Nothing @@ -394,7 +405,7 @@ supported' SMethod_TextDocumentDiagnostic $ InL $ DiagnosticOptions - { _workDoneProgress = Nothing + { _workDoneProgress = clientInitiatedProgress , _identifier = Nothing , -- TODO: this is a conservative but maybe inaccurate, unclear how much it matters _interFileDependencies = True @@ -410,7 +421,7 @@ 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 @@ -512,6 +523,19 @@ 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 + -- We need to register for `workspace/didChangeConfiguration` dynamically in order to + -- ensure we receive notifications. See + -- https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_configuration + -- https://github.com/microsoft/language-server-protocol/issues/1888 + void $ + trySendRegistration + (cmap (fmap LspCore) logger) + SMethod_WorkspaceDidChangeConfiguration + (DidChangeConfigurationRegistrationOptions (Just $ InL section)) {- | 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 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,16 +1,10 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. @@ -56,8 +50,6 @@ -- * manipulating the file contents rangeLinesFromVfs, - PosPrefixInfo (..), - getCompletionPrefix, -- * for tests applyChanges, @@ -69,22 +61,20 @@ import Control.Lens hiding (parts, (<.>)) import Control.Monad import Control.Monad.State -import Data.Char (isAlphaNum, isUpper) import Data.Foldable (traverse_) import Data.Hashable import Data.Int (Int32) import Data.List import Data.Map.Strict qualified as Map -import Data.Maybe 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.Rope qualified as URope -import Data.Text.Utf16.Rope (Rope) -import Data.Text.Utf16.Rope qualified as Rope +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 @@ -115,7 +105,7 @@ deriving (Show) data VfsLog - = SplitInsideCodePoint Rope.Position Rope + = SplitInsideCodePoint Utf16.Position Rope | URINotFound J.NormalizedUri | Opening J.NormalizedUri | Closing J.NormalizedUri @@ -350,7 +340,7 @@ applyChange logger str (J.TextDocumentContentChangeEvent (J.InL e)) | J.Range (J.Position sl sc) (J.Position fl fc) <- e .! #range , txt <- e .! #text = - changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt + 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 @@ -360,11 +350,11 @@ the given range with the new text. If the given positions lie within a code point then this does nothing (returns the original 'Rope') and logs. -} -changeChars :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> Rope.Position -> Rope.Position -> Text -> m Rope +changeChars :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> Utf16.Position -> Utf16.Position -> Text -> m Rope changeChars logger str start finish new = do - case Rope.splitAtPosition finish str of + case Rope.utf16SplitAtPosition finish str of Nothing -> logger <& SplitInsideCodePoint finish str `WithSeverity` Warning >> pure str - Just (before, after) -> case Rope.splitAtPosition start before of + Just (before, after) -> case Rope.utf16SplitAtPosition start before of Nothing -> logger <& SplitInsideCodePoint start before `WithSeverity` Warning >> pure str Just (before', _) -> pure $ mconcat [before', Rope.fromText new, after] @@ -402,11 +392,14 @@ - We then split the line at the given position, and check how long the prefix is, which takes linear time in the length of the (single) line. -We also may need to convert the line back and forth between ropes with different indexing. Again -this is linear time in the length of the line. - So the overall process is logarithmic in the number of lines, and linear in the length of the specific line. Which is okay-ish, so long as we don't have very long lines. + +We are not able to use the `Rope.splitAtPosition` +Because when column index out of range or when the column indexing at the newline char. +The prefix result would wrap over the line and having the same result (nextLineNum, 0). +We would not be able to distinguish them. When the first case should return `Nothing`, +second case should return a `Just (CurrentLineNum, columnNumberConverted)`. -} {- | Extracts a specific line from a 'Rope.Rope'. @@ -415,41 +408,12 @@ extractLine :: Rope.Rope -> Word -> Maybe Rope.Rope extractLine rope l = do -- Check for the line being out of bounds - let lastLine = Rope.posLine $ Rope.lengthAsPosition rope + let lastLine = Utf16.posLine $ Rope.utf16LengthAsPosition rope guard $ l <= lastLine - let (_, suffix) = Rope.splitAtLine l rope (prefix, _) = Rope.splitAtLine 1 suffix pure prefix -{- | Translate a code-point offset into a code-unit offset. - Linear in the length of the rope. --} -codePointOffsetToCodeUnitOffset :: URope.Rope -> Word -> Maybe Word -codePointOffsetToCodeUnitOffset rope offset = do - -- Check for the position being out of bounds - guard $ offset <= URope.length rope - -- Split at the given position in *code points* - let (prefix, _) = URope.splitAt offset rope - -- Convert the prefix to a rope using *code units* - utf16Prefix = Rope.fromText $ URope.toText prefix - -- Get the length of the prefix in *code units* - pure $ Rope.length utf16Prefix - -{- | Translate a UTF-16 code-unit offset into a code-point offset. - Linear in the length of the rope. --} -codeUnitOffsetToCodePointOffset :: Rope.Rope -> Word -> Maybe Word -codeUnitOffsetToCodePointOffset rope offset = do - -- Check for the position being out of bounds - guard $ offset <= Rope.length rope - -- Split at the given position in *code units* - (prefix, _) <- Rope.splitAt offset rope - -- Convert the prefix to a rope using *code points* - let utfPrefix = URope.fromText $ Rope.toText prefix - -- Get the length of the prefix in *code points* - pure $ URope.length utfPrefix - {- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file. Will return 'Nothing' if the requested position is out of bounds of the document. @@ -458,15 +422,12 @@ the position. -} codePointPositionToPosition :: VirtualFile -> CodePointPosition -> Maybe J.Position -codePointPositionToPosition vFile (CodePointPosition l cpc) = do +codePointPositionToPosition vFile (CodePointPosition l c) = do -- See Note [Converting between code points and code units] let text = _file_text vFile - utf16Line <- extractLine text (fromIntegral l) - -- Convert the line a rope using *code points* - let utfLine = URope.fromText $ Rope.toText utf16Line - - cuc <- codePointOffsetToCodeUnitOffset utfLine (fromIntegral cpc) - pure $ J.Position l (fromIntegral cuc) + lineRope <- extractLine text $ fromIntegral l + guard $ c <= fromIntegral (Rope.charLength lineRope) + return $ J.Position l (fromIntegral $ Rope.utf16Length $ fst $ Rope.charSplitAt (fromIntegral c) lineRope) {- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file. @@ -487,13 +448,12 @@ the position. -} positionToCodePointPosition :: VirtualFile -> J.Position -> Maybe CodePointPosition -positionToCodePointPosition vFile (J.Position l cuc) = do +positionToCodePointPosition vFile (J.Position l c) = do -- See Note [Converting between code points and code units] let text = _file_text vFile - utf16Line <- extractLine text (fromIntegral l) - - cpc <- codeUnitOffsetToCodePointOffset utf16Line (fromIntegral cuc) - pure $ CodePointPosition l (fromIntegral cpc) + lineRope <- extractLine text $ fromIntegral l + guard $ c <= fromIntegral (Rope.utf16Length lineRope) + CodePointPosition l . fromIntegral . Rope.charLength . fst <$> Rope.utf16SplitAt (fromIntegral c) lineRope {- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file. @@ -506,64 +466,9 @@ rangeToCodePointRange vFile (J.Range b e) = CodePointRange <$> positionToCodePointPosition vFile b <*> positionToCodePointPosition vFile e --- --------------------------------------------------------------------- - --- TODO:AZ:move this to somewhere sane - --- | Describes the line at the current cursor position -data PosPrefixInfo = PosPrefixInfo - { fullLine :: !T.Text - -- ^ The full contents of the line the cursor is at - , prefixModule :: !T.Text - -- ^ If any, the module name that was typed right before the cursor position. - -- For example, if the user has typed "Data.Maybe.from", then this property - -- will be "Data.Maybe" - , prefixText :: !T.Text - -- ^ The word right before the cursor position, after removing the module part. - -- For example if the user has typed "Data.Maybe.from", - -- then this property will be "from" - , cursorPos :: !J.Position - -- ^ The cursor position - } - deriving (Show, Eq) - -getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo) -getCompletionPrefix pos@(J.Position l c) (VirtualFile _ _ ropetext) = - return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do - -- Maybe monad - let lastMaybe [] = Nothing - lastMaybe xs = Just $ last xs - - let curRope = fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext - beforePos <- Rope.toText . fst <$> Rope.splitAt (fromIntegral c) curRope - curWord <- - if - | T.null beforePos -> Just "" - | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' - | otherwise -> lastMaybe (T.words beforePos) - - let parts = - T.split (== '.') $ - T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'" :: String)) curWord - case reverse parts of - [] -> Nothing - (x : xs) -> do - let modParts = - dropWhile (not . isUpper . T.head) $ - reverse $ - filter (not . T.null) xs - modName = T.intercalate "." modParts - -- curRope is already a single line, but it may include an enclosing '\n' - let curLine = T.dropWhileEnd (== '\n') $ Rope.toText curRope - return $ PosPrefixInfo curLine modName x pos - --- --------------------------------------------------------------------- - rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r where (_, s1) = Rope.splitAtLine (fromIntegral lf) ropetext (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1 r = Rope.toText s2 - --- --------------------------------------------------------------------- diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -6,7 +6,7 @@ import Data.Row import Data.String import Data.Text qualified as T -import Data.Text.Utf16.Rope qualified as Rope +import Data.Text.Utf16.Rope.Mixed qualified as Rope import Language.LSP.Protocol.Types qualified as J import Language.LSP.VFS @@ -278,27 +278,3 @@ codePointPositionToPosition vfile (CodePointPosition 2 1) `shouldBe` Nothing -- Greater line than max line codePointPositionToPosition vfile (CodePointPosition 3 0) `shouldBe` Nothing - - -- --------------------------------- - - it "getCompletionPrefix" $ do - let - orig = - T.unlines - [ "{-# ings #-}" - , "import Data.List" - ] - pp4 <- getCompletionPrefix (J.Position 0 4) (vfsFromText orig) - pp4 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 4)) - - pp5 <- getCompletionPrefix (J.Position 0 5) (vfsFromText orig) - pp5 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "i" (J.Position 0 5)) - - pp6 <- getCompletionPrefix (J.Position 0 6) (vfsFromText orig) - pp6 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "in" (J.Position 0 6)) - - pp14 <- getCompletionPrefix (J.Position 1 14) (vfsFromText orig) - pp14 `shouldBe` Just (PosPrefixInfo "import Data.List" "Data" "Li" (J.Position 1 14)) - - pp00 <- getCompletionPrefix (J.Position 0 0) (vfsFromText orig) - pp00 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 0))