lsp 2.3.0.0 → 2.4.0.0

raw patch · 11 files changed

+451/−416 lines, 11 filesdep ~aesondep ~asyncdep ~attoparsecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, async, attoparsec, bytestring, co-log-core, containers, data-default, directory, exceptions, filepath, hashable, lens, lens-aeson, mtl, prettyprinter, random, row-types, text, text-rope, transformers, unliftio-core, unordered-containers

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• example/Reactor.hs +11/−9
• example/Simple.hs +1/−1
• lsp.cabal +36/−41
• src/Language/LSP/Diagnostics.hs +0/−2
• src/Language/LSP/Server.hs +1/−1
• src/Language/LSP/Server/Control.hs +0/−2
• src/Language/LSP/Server/Core.hs +230/−107
• src/Language/LSP/Server/Processing.hs +134/−110
• src/Language/LSP/VFS.hs +23/−118
• test/VspSpec.hs +1/−25

@@ -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).

@@ -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)

@@ -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

@@ -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

@@ -1,6 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}  {- 

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExplicitNamespaces #-}  module Language.LSP.Server (   module Language.LSP.Server.Control,

@@ -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 #-}

@@ -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. -}

@@ -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

@@ -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---- ---------------------------------------------------------------------

@@ -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))