hls-plugin-api 2.0.0.1 → 2.1.0.0

raw patch · 9 files changed

+1237/−406 lines, 9 filesdep +co-log-coredep +mtldep +prettyprinterdep ~hls-graphdep ~lspPVP ok

version bump matches the API change (PVP)

Dependencies added: co-log-core, mtl, prettyprinter, row-types, stm, time, unliftio

Dependency ranges changed: hls-graph, lsp

API changes (from Hackage documentation)

Files

• hls-plugin-api.cabal +13/−3
• src/Ide/Logger.hs +316/−0
• src/Ide/Plugin/ConfigUtils.hs +26/−25
• src/Ide/Plugin/Error.hs +147/−0
• src/Ide/Plugin/RangeMap.hs +2/−3
• src/Ide/Plugin/Resolve.hs +210/−0
• src/Ide/PluginUtils.hs +111/−119
• src/Ide/Types.hs +405/−249
• test/Ide/PluginUtilsTest.hs +7/−7

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-plugin-api-version:       2.0.0.1+version:       2.1.0.0 synopsis:      Haskell Language Server API for plugin communication description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -34,17 +34,21 @@  library   exposed-modules:+    Ide.Plugin.Error     Ide.Plugin.Config     Ide.Plugin.ConfigUtils     Ide.Plugin.Properties     Ide.Plugin.RangeMap+    Ide.Plugin.Resolve     Ide.PluginUtils     Ide.Types+    Ide.Logger    hs-source-dirs:     src   build-depends:     , aeson     , base                  >=4.12    && <5+    , co-log-core     , containers     , data-default     , dependent-map@@ -55,15 +59,21 @@     , filepath     , ghc     , hashable-    , hls-graph             == 2.0.0.1+    , hls-graph             == 2.1.0.0     , lens     , lens-aeson-    , lsp                   ^>=1.6.0.0+    , lsp                   ^>=2.1.0.0+    , mtl     , opentelemetry         >=0.4     , optparse-applicative+    , prettyprinter     , regex-tdfa            >=1.3.1.0+    , row-types+    , stm     , text+    , time     , transformers+    , unliftio     , unordered-containers     , megaparsec > 9 

@@ -0,0 +1,316 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This is a compatibility module that abstracts over the+-- concrete choice of logging framework so users can plug in whatever+-- framework they want to.+module Ide.Logger+  ( Priority(..)+  , Logger(..)+  , Recorder(..)+  , logError, logWarning, logInfo, logDebug+  , noLogging+  , WithPriority(..)+  , logWith+  , cmap+  , cmapIO+  , cfilter+  , withFileRecorder+  , makeDefaultStderrRecorder+  , makeDefaultHandleRecorder+  , LoggingColumn(..)+  , cmapWithPrio+  , withBacklog+  , lspClientMessageRecorder+  , lspClientLogRecorder+  , module PrettyPrinterModule+  , renderStrict+  , toCologActionWithPrio+  ) where++import           Colog.Core                    (LogAction (..), Severity,+                                                WithSeverity (..))+import qualified Colog.Core                    as Colog+import           Control.Concurrent            (myThreadId)+import           Control.Concurrent.Extra      (Lock, newLock, withLock)+import           Control.Concurrent.STM        (atomically, flushTBQueue,+                                                isFullTBQueue, newTBQueueIO,+                                                newTVarIO, readTVarIO,+                                                writeTBQueue, writeTVar)+import           Control.Exception             (IOException)+import           Control.Monad                 (unless, when, (>=>))+import           Control.Monad.IO.Class        (MonadIO (liftIO))+import           Data.Foldable                 (for_)+import           Data.Functor.Contravariant    (Contravariant (contramap))+import           Data.Maybe                    (fromMaybe)+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import qualified Data.Text                     as Text+import qualified Data.Text.IO                  as Text+import           Data.Time                     (defaultTimeLocale, formatTime,+                                                getCurrentTime)+import           GHC.Stack                     (CallStack, HasCallStack,+                                                SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),+                                                callStack, getCallStack,+                                                withFrozenCallStack)+import           Language.LSP.Protocol.Message (SMethod (SMethod_WindowLogMessage, SMethod_WindowShowMessage))+import           Language.LSP.Protocol.Types   (LogMessageParams (..),+                                                MessageType (..),+                                                ShowMessageParams (..))+import           Language.LSP.Server+import qualified Language.LSP.Server           as LSP+import           Prettyprinter                 as PrettyPrinterModule+import           Prettyprinter.Render.Text     (renderStrict)+import           System.IO                     (Handle, IOMode (AppendMode),+                                                hClose, hFlush, openFile,+                                                stderr)+import           UnliftIO                      (MonadUnliftIO, finally, try)++data Priority+-- Don't change the ordering of this type or you will mess up the Ord+-- instance+    = Debug -- ^ Verbose debug logging.+    | Info  -- ^ Useful information in case an error has to be understood.+    | Warning+      -- ^ These error messages should not occur in a expected usage, and+      -- should be investigated.+    | Error -- ^ Such log messages must never occur in expected usage.+    deriving (Eq, Show, Read, Ord, Enum, Bounded)++-- | Note that this is logging actions _of the program_, not of the user.+--   You shouldn't call warning/error if the user has caused an error, only+--   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).+newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}++instance Semigroup Logger where+    l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t++instance Monoid Logger where+    mempty = Logger $ \_ _ -> pure ()++logError :: Logger -> T.Text -> IO ()+logError x = logPriority x Error++logWarning :: Logger -> T.Text -> IO ()+logWarning x = logPriority x Warning++logInfo :: Logger -> T.Text -> IO ()+logInfo x = logPriority x Info++logDebug :: Logger -> T.Text -> IO ()+logDebug x = logPriority x Debug++noLogging :: Logger+noLogging = Logger $ \_ _ -> return ()++data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor++-- | Note that this is logging actions _of the program_, not of the user.+--   You shouldn't call warning/error if the user has caused an error, only+--   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).+newtype Recorder msg = Recorder+  { logger_ :: forall m. (MonadIO m) => msg -> m () }++logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m ()+logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg)++instance Semigroup (Recorder msg) where+  (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } =+    Recorder+      { logger_ = \msg -> logger_1 msg >> logger_2 msg }++instance Monoid (Recorder msg) where+  mempty =+    Recorder+      { logger_ = \_ -> pure () }++instance Contravariant Recorder where+  contramap f Recorder{ logger_ } =+    Recorder+      { logger_ = logger_ . f }++cmap :: (a -> b) -> Recorder b -> Recorder a+cmap = contramap++cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)+cmapWithPrio f = cmap (fmap f)++cmapIO :: (a -> IO b) -> Recorder b -> Recorder a+cmapIO f Recorder{ logger_ } =+  Recorder+    { logger_ = (liftIO . f) >=> logger_ }++cfilter :: (a -> Bool) -> Recorder a -> Recorder a+cfilter p Recorder{ logger_ } =+  Recorder+    { logger_ = \msg -> when (p msg) (logger_ msg) }++textHandleRecorder :: Handle -> Recorder Text+textHandleRecorder handle =+  Recorder+    { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle }++makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))+makeDefaultStderrRecorder columns = do+  lock <- liftIO newLock+  makeDefaultHandleRecorder columns lock stderr++withFileRecorder+  :: MonadUnliftIO m+  => FilePath+  -- ^ Log file path.+  -> Maybe [LoggingColumn]+  -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`+  -> (Either IOException (Recorder (WithPriority (Doc d))) -> m a)+  -- ^ action given a recorder, or the exception if we failed to open the file+  -> m a+withFileRecorder path columns action = do+  lock <- liftIO newLock+  let makeHandleRecorder = makeDefaultHandleRecorder columns lock+  fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)+  case fileHandle of+    Left e -> action $ Left e+    Right fileHandle -> finally ((Right <$> makeHandleRecorder fileHandle) >>= action) (liftIO $ hClose fileHandle)++makeDefaultHandleRecorder+  :: MonadIO m+  => Maybe [LoggingColumn]+  -- ^ built-in logging columns to display. Nothing uses the default+  -> Lock+  -- ^ lock to take when outputting to handle+  -> Handle+  -- ^ handle to output to+  -> m (Recorder (WithPriority (Doc a)))+makeDefaultHandleRecorder columns lock handle = do+  let Recorder{ logger_ } = textHandleRecorder handle+  let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) }+  let loggingColumns = fromMaybe defaultLoggingColumns columns+  let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder+  pure (cmap docToText textWithPriorityRecorder)+  where+    docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions)++data LoggingColumn+  = TimeColumn+  | ThreadIdColumn+  | PriorityColumn+  | DataColumn+  | SourceLocColumn++defaultLoggingColumns :: [LoggingColumn]+defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn]++textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text+textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do+    textColumns <- mapM loggingColumnToText columns+    pure $ Text.intercalate " | " textColumns+    where+      showAsText :: Show a => a -> Text+      showAsText = Text.pack . show++      utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime++      priorityToText :: Priority -> Text+      priorityToText = showAsText++      threadIdToText = showAsText++      callStackToSrcLoc :: CallStack -> Maybe SrcLoc+      callStackToSrcLoc callStack =+        case getCallStack callStack of+          (_, srcLoc) : _ -> Just srcLoc+          _               -> Nothing++      srcLocToText = \case+          Nothing -> "<unknown>"+          Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } ->+            Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol++      loggingColumnToText :: LoggingColumn -> IO Text+      loggingColumnToText = \case+        TimeColumn -> do+          utcTime <- getCurrentTime+          pure (utcTimeToText utcTime)+        SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_+        ThreadIdColumn -> do+          threadId <- myThreadId+          pure (threadIdToText threadId)+        PriorityColumn -> pure (priorityToText priority)+        DataColumn -> pure payload++-- | Given a 'Recorder' that requires an argument, produces a 'Recorder'+-- that queues up messages until the argument is provided using the callback, at which+-- point it sends the backlog and begins functioning normally.+withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())+withBacklog recFun = do+  -- Arbitrary backlog capacity+  backlog <- newTBQueueIO 100+  let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do+          -- If the queue is full just drop the message on the floor. This is most likely+          -- to happen if the callback is just never going to be called; in which case+          -- we want neither to build up an unbounded backlog in memory, nor block waiting+          -- for space!+          full <- isFullTBQueue backlog+          unless full $ writeTBQueue backlog it++  -- The variable holding the recorder starts out holding the recorder that writes+  -- to the backlog.+  recVar <- newTVarIO backlogRecorder+  -- The callback atomically swaps out the recorder for the final one, and flushes+  -- the backlog to it.+  let cb arg = do+        let recorder = recFun arg+        toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog+        for_ toRecord (logger_ recorder)++  -- The recorder we actually return looks in the variable and uses whatever is there.+  let varRecorder = Recorder $ \it -> do+          r <- liftIO $ readTVarIO recVar+          logger_ r it++  pure (varRecorder, cb)++-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.+lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)+lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->+  liftIO $ LSP.runLspT env $ LSP.sendNotification SMethod_WindowShowMessage+      ShowMessageParams+        { _type_ = priorityToLsp priority,+          _message = payload+        }++-- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.+lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)+lspClientLogRecorder env = Recorder $ \WithPriority {..} ->+  liftIO $ LSP.runLspT env $ LSP.sendNotification SMethod_WindowLogMessage+      LogMessageParams+        { _type_ = priorityToLsp priority,+          _message = payload+        }++priorityToLsp :: Priority -> MessageType+priorityToLsp =+  \case+    Debug   -> MessageType_Log+    Info    -> MessageType_Info+    Warning -> MessageType_Warning+    Error   -> MessageType_Error++toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)+toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do+    let priority = severityToPriority getSeverity+    _logger $ WithPriority priority callStack getMsg+  where+    severityToPriority :: Severity -> Priority+    severityToPriority Colog.Debug   = Debug+    severityToPriority Colog.Info    = Info+    severityToPriority Colog.Warning = Warning+    severityToPriority Colog.Error   = Error

@@ -5,20 +5,21 @@  module Ide.Plugin.ConfigUtils where -import           Control.Lens          (at, ix, (&), (?~))-import qualified Data.Aeson            as A-import           Data.Aeson.Lens       (_Object)-import qualified Data.Aeson.Types      as A+import           Control.Lens                  (at, ix, (&), (?~))+import qualified Data.Aeson                    as A+import           Data.Aeson.Lens               (_Object)+import qualified Data.Aeson.Types              as A import           Data.Default-import qualified Data.Dependent.Map    as DMap-import qualified Data.Dependent.Sum    as DSum-import           Data.List.Extra       (nubOrd)-import           Data.String           (IsString (fromString))-import qualified Data.Text             as T+import qualified Data.Dependent.Map            as DMap+import qualified Data.Dependent.Sum            as DSum+import           Data.List.Extra               (nubOrd)+import           Data.String                   (IsString (fromString))+import qualified Data.Text                     as T import           Ide.Plugin.Config-import           Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)+import           Ide.Plugin.Properties         (toDefaultJSON,+                                                toVSCodeExtensionSchema) import           Ide.Types-import           Language.LSP.Types+import           Language.LSP.Protocol.Message  -- Attention: -- 'diagnosticsOn' will never be added into the default config or the schema,@@ -86,13 +87,13 @@         -- This function captures ide methods registered by the plugin, and then converts it to kv pairs         handlersToGenericDefaultConfig :: PluginConfig -> DSum.DSum IdeMethod f -> [A.Pair]         handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of-          STextDocumentCodeAction           -> ["codeActionsOn" A..= plcCodeActionsOn]-          STextDocumentCodeLens             -> ["codeLensOn" A..= plcCodeLensOn]-          STextDocumentRename               -> ["renameOn" A..= plcRenameOn]-          STextDocumentHover                -> ["hoverOn" A..= plcHoverOn]-          STextDocumentDocumentSymbol       -> ["symbolsOn" A..= plcSymbolsOn]-          STextDocumentCompletion           -> ["completionOn" A..= plcCompletionOn]-          STextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]+          SMethod_TextDocumentCodeAction           -> ["codeActionsOn" A..= plcCodeActionsOn]+          SMethod_TextDocumentCodeLens             -> ["codeLensOn" A..= plcCodeLensOn]+          SMethod_TextDocumentRename               -> ["renameOn" A..= plcRenameOn]+          SMethod_TextDocumentHover                -> ["hoverOn" A..= plcHoverOn]+          SMethod_TextDocumentDocumentSymbol       -> ["symbolsOn" A..= plcSymbolsOn]+          SMethod_TextDocumentCompletion           -> ["completionOn" A..= plcCompletionOn]+          SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]           _                                 -> []  -- | Generates json schema used in haskell vscode extension@@ -116,13 +117,13 @@                 _   -> x         dedicatedSchema = customConfigToDedicatedSchema configCustomConfig         handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of-          STextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions"]-          STextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses"]-          STextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename"]-          STextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover"]-          STextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"]-          STextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"]-          STextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy"]+          SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions"]+          SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses"]+          SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename"]+          SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover"]+          SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"]+          SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"]+          SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy"]           _ -> []         schemaEntry desc =           A.object

@@ -0,0 +1,147 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE OverloadedStrings         #-}+module Ide.Plugin.Error (+      -- * Plugin Error Handling API+    PluginError(..),+    toErrorCode,+    toPriority,+    handleMaybe,+    handleMaybeM,+    getNormalizedFilePathE,+) where++import           Control.Monad.Extra         (maybeM)+import           Control.Monad.Trans.Class   (lift)+import           Control.Monad.Trans.Except  (ExceptT (..), throwE)+import qualified Data.Text                   as T+import           Ide.Logger+import           Language.LSP.Protocol.Types++-- ----------------------------------------------------------------------------+-- Plugin Error wrapping+-- ----------------------------------------------------------------------------++-- |Each PluginError corresponds to either a specific ResponseError we want to+-- return or a specific way we want to log the error. If the currently present+-- ones are insufficient for the needs of your plugin, please feel free to add+-- a new one.+--+-- Currently the PluginErrors we provide can be broken up into several groups.+-- First is PluginInternalError, which is the most serious of the errors, and+-- also the "default" error that is used for things such as uncaught exceptions.+-- Then we have PluginInvalidParams, which along with PluginInternalError map+-- to a corresponding ResponseError.+--+-- Next we have PluginRuleFailed and PluginInvalidUserState, with the only+-- difference being PluginRuleFailed is specific to Shake rules and+-- PluginInvalidUserState can be used for everything else. Both of these are+-- "non-errors", and happen whenever the user's code is in a state where the+-- plugin is unable to provide a answer to the users request. PluginStaleResolve+-- is similar to the above two Error types, but is specific to resolve plugins,+-- and is used only when the data provided by the resolve request is stale,+-- preventing the proper resolution of it.+--+-- Finally we have the outlier, PluginRequestRefused, where we allow a handler+-- to preform "pluginEnabled" checks inside the handler, and reject the request+-- after viewing it. The behavior of only one handler passing `pluginEnabled`+-- and then returning PluginRequestRefused should be the same as if no plugins+-- passed the `pluginEnabled` stage.+data PluginError+  = -- |PluginInternalError should be used if an error has occurred. This+    -- should only rarely be returned. As it's logged with Error, it will be+    -- shown by the client to the user via `showWindow`. All uncaught exceptions+    -- will be caught and converted to this error.+    --+    -- This error will be be converted into an InternalError response code. It+    -- will be logged with Error and takes the highest precedence (1) in being+    -- returned as a response to the client.+    PluginInternalError T.Text+    -- |PluginInvalidParams should be used if the parameters of the request are+    -- invalid. This error means that there is a bug in the client's code+    -- (otherwise they wouldn't be sending you requests with invalid+    -- parameters).+    --+    -- This error will be will be converted into a InvalidParams response code.+    -- It will be logged with Warning and takes medium precedence (2) in being+    -- returned as a response to the client.+  | PluginInvalidParams T.Text+    -- |PluginInvalidUserState should be thrown when a function that your plugin+    -- depends on fails. This should only be used when the function fails+    -- because the user's code is in an invalid state.+    --+    -- This error takes the name of the function that failed. Prefer to catch+    -- this error as close to the source as possible.+    --+    -- This error will be logged with Debug, and will be converted into a+    -- RequestFailed response. It takes a low precedence (3) in being returned+    -- as a response to the client.+  | PluginInvalidUserState T.Text+    -- |PluginRequestRefused allows your handler to inspect a request before+    -- rejecting it. In effect it allows your plugin to act make a secondary+    -- `pluginEnabled` decision after receiving the request. This should only be+    -- used if the decision to accept the request can not be made in+    -- `pluginEnabled`.+    --+    -- This error will be with Debug. If it's the only response to a request,+    -- HLS will respond as if no plugins passed the `pluginEnabled` stage.+  | PluginRequestRefused T.Text+    -- |PluginRuleFailed should be thrown when a Rule your response depends on+    -- fails.+    --+    -- This error takes the name of the Rule that failed.+    --+    -- This error will be logged with Debug, and will be converted into a+    -- RequestFailed response code. It takes a low precedence (3) in being+    -- returned as a response to the client.+  | PluginRuleFailed T.Text+    -- |PluginStaleResolve should be thrown when your resolve request is+    -- provided with data it can no longer resolve.+    --+    -- This error will be logged with Debug, and will be converted into a+    -- ContentModified response. It takes a low precedence (3) in being returned+    -- as a response to the client.+  | PluginStaleResolve++instance Pretty PluginError where+    pretty = \case+      PluginInternalError msg     -> "Internal Error:"     <+> pretty msg+      PluginStaleResolve          -> "Stale Resolve"+      PluginRuleFailed rule       -> "Rule Failed:"        <+> pretty rule+      PluginInvalidParams text    -> "Invalid Params:"     <+> pretty text+      PluginInvalidUserState text -> "Invalid User State:" <+> pretty text+      PluginRequestRefused msg    -> "Request Refused: "   <+> pretty msg++-- |Converts to ErrorCode used in LSP ResponseErrors+toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes)+toErrorCode (PluginInternalError _)    = InR ErrorCodes_InternalError+toErrorCode (PluginInvalidParams _)    = InR ErrorCodes_InvalidParams+toErrorCode (PluginInvalidUserState _) = InL LSPErrorCodes_RequestFailed+-- PluginRequestRefused should never be a argument to `toResponseError`, as+-- it should be dealt with in `extensiblePlugins`, but this is here to make+-- this function complete+toErrorCode (PluginRequestRefused _)   = InR ErrorCodes_MethodNotFound+toErrorCode (PluginRuleFailed _)       = InL LSPErrorCodes_RequestFailed+toErrorCode PluginStaleResolve         = InL LSPErrorCodes_ContentModified++-- |Converts to a logging priority. In addition to being used by the logger,+-- `combineResponses` currently uses this to  choose which response to return,+-- so care should be taken in changing it.+toPriority :: PluginError -> Priority+toPriority (PluginInternalError _)    = Error+toPriority (PluginInvalidParams _)    = Warning+toPriority (PluginInvalidUserState _) = Debug+toPriority (PluginRequestRefused _)   = Debug+toPriority (PluginRuleFailed _)       = Debug+toPriority PluginStaleResolve         = Debug++handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b+handleMaybe msg = maybe (throwE msg) return++handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b+handleMaybeM msg act = maybeM (throwE msg) return $ lift act++getNormalizedFilePathE :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath+getNormalizedFilePathE uri = handleMaybe (PluginInvalidParams (T.pack $ "uriToNormalizedFile failed. Uri:" <>  show uri))+        $ uriToNormalizedFilePath+        $ toNormalizedUri uri

@@ -22,9 +22,8 @@ import           Data.Bifunctor                           (first) import           Data.Foldable                            (foldl') import           Development.IDE.Graph.Classes            (NFData)-import           Language.LSP.Types                       (Position,-                                                           Range (Range),-                                                           isSubrangeOf)+import           Language.LSP.Protocol.Types              (Position,+                                                           Range (Range)) #ifdef USE_FINGERTREE import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM #endif

@@ -0,0 +1,210 @@+{-# LANGUAGE DeriveGeneric            #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase               #-}+{-# LANGUAGE NamedFieldPuns           #-}+{-# LANGUAGE OverloadedLabels         #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE RankNTypes               #-}+{-# LANGUAGE ScopedTypeVariables      #-}+module Ide.Plugin.Resolve+(mkCodeActionHandlerWithResolve,+mkCodeActionWithResolveAndCommand) where++import           Control.Lens                  (_Just, (&), (.~), (?~), (^.),+                                                (^?))+import           Control.Monad.Error.Class     (MonadError (throwError))+import           Control.Monad.Trans.Class     (lift)+import           Control.Monad.Trans.Except    (ExceptT (..), runExceptT)++import qualified Data.Aeson                    as A+import           Data.Maybe                    (catMaybes)+import           Data.Row                      ((.!))+import qualified Data.Text                     as T+import           GHC.Generics                  (Generic)+import           Ide.Logger+import           Ide.Plugin.Error+import           Ide.Types+import qualified Language.LSP.Protocol.Lens    as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server           (LspT,+                                                ProgressCancellable (Cancellable),+                                                getClientCapabilities,+                                                sendRequest,+                                                withIndefiniteProgress)++data Log+    = DoesNotSupportResolve T.Text+    | ApplyWorkspaceEditFailed ResponseError+instance Pretty Log where+    pretty = \case+        DoesNotSupportResolve fallback->+            "Client does not support resolve," <+> pretty fallback+        ApplyWorkspaceEditFailed err ->+            "ApplyWorkspaceEditFailed:" <+> viaShow err++-- |When provided with both a codeAction provider and an affiliated codeAction+-- resolve provider, this function creates a handler that automatically uses+-- your resolve provider to fill out you original codeAction if the client doesn't+-- have codeAction resolve support. This means you don't have to check whether+-- the client supports resolve and act accordingly in your own providers.+mkCodeActionHandlerWithResolve+  :: forall ideState a. (A.FromJSON a) =>+  Recorder (WithPriority Log)+  -> PluginMethodHandler ideState 'Method_TextDocumentCodeAction+  -> ResolveFunction ideState a 'Method_CodeActionResolve+  -> PluginHandlers ideState+mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod =+  let newCodeActionMethod ideState pid params =+        do codeActionReturn <- codeActionMethod ideState pid params+           caps <- lift getClientCapabilities+           case codeActionReturn of+             r@(InR Null) -> pure r+             (InL ls) | -- We don't need to do anything if the client supports+                        -- resolve+                        supportsCodeActionResolve caps -> pure $ InL ls+                        --This is the actual part where we call resolveCodeAction which fills in the edit data for the client+                      | otherwise -> do+                        logWith recorder Debug (DoesNotSupportResolve "filling in the code action")+                        InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls+  in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod+  <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod)+  where dropData :: CodeAction -> CodeAction+        dropData ca = ca & L.data_ .~ Nothing+        resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (LspT Config IO) (Command |? CodeAction)+        resolveCodeAction _uri _ideState _plId c@(InL _) = pure c+        resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do+          case A.fromJSON value of+            A.Error err -> throwError $ parseError (Just value) (T.pack err)+            A.Success innerValueDecoded -> do+              resolveResult <- codeResolveMethod ideState pid codeAction uri innerValueDecoded+              case resolveResult of+                CodeAction {_edit = Just _ } -> do+                  pure $ InR $ dropData resolveResult+                _ -> throwError $ invalidParamsError "Returned CodeAction has no data field"+        resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwError $ invalidParamsError "CodeAction has no data field"+++-- |When provided with both a codeAction provider with a data field and a resolve+--  provider, this function creates a handler that creates a command that uses+-- your resolve if the client doesn't have code action resolve support. This means+-- you don't have to check whether the client supports resolve and act+-- accordingly in your own providers. see Note [Code action resolve fallback to commands]+-- Also: This helper only works with workspace edits, not commands. Any command set+-- either in the original code action or in the resolve will be ignored.+mkCodeActionWithResolveAndCommand+  :: forall ideState a. (A.FromJSON a) =>+  Recorder (WithPriority Log)+  -> PluginId+  -> PluginMethodHandler ideState 'Method_TextDocumentCodeAction+  -> ResolveFunction ideState a 'Method_CodeActionResolve+  -> ([PluginCommand ideState], PluginHandlers ideState)+mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod =+  let newCodeActionMethod ideState pid params =+        do codeActionReturn <- codeActionMethod ideState pid params+           caps <- lift getClientCapabilities+           case codeActionReturn of+             r@(InR Null) -> pure r+             (InL ls) | -- We don't need to do anything if the client supports+                        -- resolve+                        supportsCodeActionResolve caps -> pure $ InL ls+                        -- If they do not we will drop the data field, in addition we will populate the command+                        -- field with our command to execute the resolve, with the whole code action as it's argument.+                      | otherwise -> do+                        logWith recorder Debug (DoesNotSupportResolve "rewriting the code action to use commands")+                        pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls+  in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd codeResolveMethod)],+  mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod+  <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod)+  where moveDataToCommand :: Uri -> Command |? CodeAction -> Command |? CodeAction+        moveDataToCommand uri ca =+          let dat = A.toJSON . wrapWithURI uri <$> ca ^? _R -- We need to take the whole codeAction+              -- And put it in the argument for the Command, that way we can later+              -- pass it to the resolve handler (which expects a whole code action)+              -- It should be noted that mkLspCommand already specifies the command+              -- to the plugin, so we don't need to do that here.+              cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat)+          in ca+              & _R . L.data_ .~ Nothing -- Set the data field to nothing+              & _R . L.command ?~ cmd -- And set the command to our previously created command+        wrapWithURI ::  Uri -> CodeAction -> CodeAction+        wrapWithURI  uri codeAction =+          codeAction & L.data_ .~  (A.toJSON .WithURI uri <$> data_)+          where data_ = codeAction ^? L.data_ . _Just+        executeResolveCmd :: ResolveFunction ideState a 'Method_CodeActionResolve -> CommandFunction ideState CodeAction+        executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do+          ExceptT $ withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do+            case A.fromJSON value of+              A.Error err -> throwError $ parseError (Just value) (T.pack err)+              A.Success (WithURI uri innerValue) -> do+                case A.fromJSON innerValue of+                  A.Error err -> throwError $ parseError (Just value) (T.pack err)+                  A.Success innerValueDecoded -> do+                    resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded+                    case resolveResult of+                      ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do+                          _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback+                          pure $ InR Null+                      ca2@CodeAction {_edit = Just _ }  ->+                        throwError $ internalError $+                            "The resolve provider unexpectedly returned a code action with the following differing fields: "+                            <> (T.pack $ show $  diffCodeActions ca ca2)+                      _ -> throwError $ internalError "The resolve provider unexpectedly returned a result with no data field"+        executeResolveCmd _ _ CodeAction{_data_= value} = throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value))+        handleWEditCallback (Left err ) = do+            logWith recorder Warning (ApplyWorkspaceEditFailed err)+            pure ()+        handleWEditCallback _ = pure ()++-- TODO: Remove once provided by lsp-types+-- |Compares two CodeActions and returns a list of fields that are not equal+diffCodeActions :: CodeAction -> CodeAction -> [T.Text]+diffCodeActions ca ca2 =+  let titleDiff = if ca ^. L.title == ca2 ^. L.title then Nothing else Just "title"+      kindDiff = if ca ^. L.kind == ca2 ^. L.kind then Nothing else Just "kind"+      diagnosticsDiff = if ca ^. L.diagnostics == ca2 ^. L.diagnostics then Nothing else Just "diagnostics"+      commandDiff = if ca ^. L.command == ca2 ^. L.command then Nothing else Just "diagnostics"+      isPreferredDiff = if ca ^. L.isPreferred == ca2 ^. L.isPreferred then Nothing else Just "isPreferred"+      dataDiff = if ca ^. L.data_ == ca2 ^. L.data_ then Nothing else Just "data"+      disabledDiff = if ca ^. L.disabled == ca2 ^. L.disabled then Nothing else Just "disabled"+      editDiff = if ca ^. L.edit == ca2 ^. L.edit then Nothing else Just "edit"+  in catMaybes [titleDiff, kindDiff, diagnosticsDiff, commandDiff, isPreferredDiff, dataDiff, disabledDiff, editDiff]++-- |To execute the resolve provider as a command, we need to additionally store+-- the URI that was provided to the original code action.+data WithURI = WithURI {+ _uri    :: Uri+, _value :: A.Value+} deriving (Generic, Show)+instance A.ToJSON WithURI+instance A.FromJSON WithURI++-- |Checks if the the client supports resolve for code action. We currently only check+--  whether resolve for the edit field is supported, because that's the only one we care+-- about at the moment.+supportsCodeActionResolve :: ClientCapabilities -> Bool+supportsCodeActionResolve caps =+    caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True+    && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of+        Just row -> "edit" `elem` row .! #properties+        _        -> False++internalError :: T.Text -> PluginError+internalError msg = PluginInternalError ("Ide.Plugin.Resolve: " <> msg)++invalidParamsError :: T.Text -> PluginError+invalidParamsError msg = PluginInvalidParams ("Ide.Plugin.Resolve: : " <> msg)++parseError :: Maybe A.Value -> T.Text -> PluginError+parseError value errMsg = PluginInternalError ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg)++{- Note [Code action resolve fallback to commands]+  To make supporting code action resolve easy for plugins, we want to let them+  provide one implementation that can be used both when clients support+  resolve, and when they don't.+  The way we do this is to have them always implement a resolve handler.+  Then, if the client doesn't support resolve, we instead install the resolve+  handler as a _command_ handler, passing the code action literal itself+  as the command argument. This allows the command handler to have+  the same interface as the resolve handler!+  -}

@@ -1,11 +1,14 @@ {-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}+ module Ide.PluginUtils   ( -- * LSP Range manipulation functions     normalize,     extendNextLine,     extendLineStart,+    extendToFullLines,     WithDeletions(..),     getProcessID,     makeDiffTextEdit,@@ -14,12 +17,11 @@     diffText',     pluginDescToIdePlugins,     idePluginsToPluginDesc,-    responseError,     getClientConfig,     getPluginConfig,     configForPlugin,     pluginEnabled,-    extractRange,+    extractTextInRange,     fullRange,     mkLspCommand,     mkLspCmdId,@@ -30,42 +32,29 @@     subRange,     positionInRange,     usePropertyLsp,-    getNormalizedFilePath,-    pluginResponse,-    handleMaybe,-    handleMaybeM,-    throwPluginError,+    -- * Escape     unescape,-    )+  ) where --import           Control.Arrow                   ((&&&))-import           Control.Monad.Extra             (maybeM)-import           Control.Monad.Trans.Class       (lift)-import           Control.Monad.Trans.Except      (ExceptT, runExceptT, throwE)+import           Control.Arrow               ((&&&))+import           Control.Lens                (_head, _last, re, (%~), (^.)) import           Data.Algorithm.Diff import           Data.Algorithm.DiffOutput-import           Data.Bifunctor                  (Bifunctor (first))-import           Data.Char                       (isPrint, showLitChar)-import           Data.Functor                    (void)-import qualified Data.HashMap.Strict             as H-import           Data.String                     (IsString (fromString))-import qualified Data.Text                       as T-import           Data.Void                       (Void)+import           Data.Char                   (isPrint, showLitChar)+import           Data.Functor                (void)+import qualified Data.Map                    as M+import qualified Data.Text                   as T+import           Data.Void                   (Void) import           Ide.Plugin.Config import           Ide.Plugin.Properties import           Ide.Types+import qualified Language.LSP.Protocol.Lens  as L+import           Language.LSP.Protocol.Types import           Language.LSP.Server-import           Language.LSP.Types              hiding-                                                 (SemanticTokenAbsolute (length, line),-                                                  SemanticTokenRelative (length),-                                                  SemanticTokensEdit (_start))-import qualified Language.LSP.Types              as J-import           Language.LSP.Types.Capabilities-import qualified Text.Megaparsec                 as P-import qualified Text.Megaparsec.Char            as P-import qualified Text.Megaparsec.Char.Lexer      as P+import qualified Text.Megaparsec             as P+import qualified Text.Megaparsec.Char        as P+import qualified Text.Megaparsec.Char.Lexer  as P  -- --------------------------------------------------------------------- @@ -92,39 +81,56 @@ extendLineStart (Range (Position sl _) e) =   Range (Position sl 0) e +-- | Extend 'Range' to include the start of the first line and start of the next line of the last line.+--+-- Caveat: It always extend the last line to the beginning of next line, even when the last position is at column 0.+-- This is to keep the compatibility with the implementation of old function @extractRange@.+--+-- >>> extendToFullLines (Range (Position 5 5) (Position 5 10))+-- Range (Position 5 0) (Position 6 0)+--+-- >>> extendToFullLines (Range (Position 5 5) (Position 7 2))+-- Range (Position 5 0) (Position 8 0)+--+-- >>> extendToFullLines (Range (Position 5 5) (Position 7 0))+-- Range (Position 5 0) (Position 8 0)+extendToFullLines :: Range -> Range+extendToFullLines = extendLineStart . extendNextLine++ -- ---------------------------------------------------------------------  data WithDeletions = IncludeDeletions | SkipDeletions-  deriving Eq+  deriving (Eq)  -- | Generate a 'WorkspaceEdit' value from a pair of source Text-diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit+diffText :: ClientCapabilities -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit diffText clientCaps old new withDeletions =-  let-    supports = clientSupportsDocumentChanges clientCaps-  in diffText' supports old new withDeletions+  let supports = clientSupportsDocumentChanges clientCaps+   in diffText' supports old new withDeletions -makeDiffTextEdit :: T.Text -> T.Text -> List TextEdit+makeDiffTextEdit :: T.Text -> T.Text -> [TextEdit] makeDiffTextEdit f1 f2 = diffTextEdit f1 f2 IncludeDeletions -makeDiffTextEditAdditive :: T.Text -> T.Text -> List TextEdit+makeDiffTextEditAdditive :: T.Text -> T.Text -> [TextEdit] makeDiffTextEditAdditive f1 f2 = diffTextEdit f1 f2 SkipDeletions -diffTextEdit :: T.Text -> T.Text -> WithDeletions -> List TextEdit-diffTextEdit fText f2Text withDeletions = J.List r+diffTextEdit :: T.Text -> T.Text -> WithDeletions -> [TextEdit]+diffTextEdit fText f2Text withDeletions = r   where     r = map diffOperationToTextEdit diffOps     d = getGroupedDiff (lines $ T.unpack fText) (lines $ T.unpack f2Text) -    diffOps = filter (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x))-                     (diffToLineRanges d)+    diffOps =+      filter+        (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x))+        (diffToLineRanges d)      isDeletion (Deletion _ _) = True     isDeletion _              = False --    diffOperationToTextEdit :: DiffOperation LineRange -> J.TextEdit-    diffOperationToTextEdit (Change fm to) = J.TextEdit range nt+    diffOperationToTextEdit :: DiffOperation LineRange -> TextEdit+    diffOperationToTextEdit (Change fm to) = TextEdit range nt       where         range = calcRange fm         nt = T.pack $ init $ unlines $ lrContents to@@ -136,53 +142,54 @@       the line ending character(s) then use an end position denoting       the start of the next line"     -}-    diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range ""+    diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = TextEdit range ""       where-        range = J.Range (J.Position (fromIntegral $ sl - 1) 0)-                        (J.Position (fromIntegral el) 0)--    diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt-    -- fm has a range wrt to the changed file, which starts in the current file at l + 1-    -- So the range has to be shifted to start at l + 1+        range =+          Range+            (Position (fromIntegral $ sl - 1) 0)+            (Position (fromIntegral el) 0)+    diffOperationToTextEdit (Addition fm l) = TextEdit range nt       where-        range = J.Range (J.Position (fromIntegral l) 0)-                        (J.Position (fromIntegral l) 0)-        nt = T.pack $ unlines $ lrContents fm+        -- fm has a range wrt to the changed file, which starts in the current file at l + 1+        -- So the range has to be shifted to start at l + 1 +        range =+          Range+            (Position (fromIntegral l) 0)+            (Position (fromIntegral l) 0)+        nt = T.pack $ unlines $ lrContents fm -    calcRange fm = J.Range s e+    calcRange fm = Range s e       where         sl = fst $ lrNumbers fm         sc = 0-        s = J.Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines+        s = Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines         el = snd $ lrNumbers fm         ec = fromIntegral $ length $ last $ lrContents fm-        e = J.Position (fromIntegral $ el - 1) ec  -- Note: zero-based lines-+        e = Position (fromIntegral $ el - 1) ec -- Note: zero-based lines  -- | A pure version of 'diffText' for testing-diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit-diffText' supports (f,fText) f2Text withDeletions  =+diffText' :: Bool -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit+diffText' supports (verTxtDocId, fText) f2Text withDeletions =   if supports     then WorkspaceEdit Nothing (Just docChanges) Nothing     else WorkspaceEdit (Just h) Nothing Nothing   where     diff = diffTextEdit fText f2Text withDeletions-    h = H.singleton f diff-    docChanges = J.List [InL docEdit]-    docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) $ fmap InL diff+    h = M.singleton (verTxtDocId ^. L.uri) diff+    docChanges = [InL docEdit]+    docEdit = TextDocumentEdit (verTxtDocId ^. re _versionedTextDocumentIdentifier) $ fmap InL diff  -- ---------------------------------------------------------------------  clientSupportsDocumentChanges :: ClientCapabilities -> Bool clientSupportsDocumentChanges caps =-  let ClientCapabilities mwCaps _ _ _ _ = caps+  let ClientCapabilities mwCaps _ _ _ _ _ = caps       supports = do         wCaps <- mwCaps         WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps         mDc-  in-    Just True == supports+   in Just True == supports  -- --------------------------------------------------------------------- @@ -193,11 +200,11 @@ idePluginsToPluginDesc (IdePlugins pp) = pp  -- ---------------------------------------------------------------------+ -- | Returns the current client configuration. It is not wise to permanently -- cache the returned value of this function, as clients can at runtime change -- their configuration.----getClientConfig :: MonadLsp Config m => m Config+getClientConfig :: (MonadLsp Config m) => m Config getClientConfig = getConfig  -- ---------------------------------------------------------------------@@ -205,10 +212,10 @@ -- | Returns the current plugin configuration. It is not wise to permanently -- cache the returned value of this function, as clients can change their -- configuration at runtime.-getPluginConfig :: MonadLsp Config m => PluginDescriptor c -> m PluginConfig+getPluginConfig :: (MonadLsp Config m) => PluginDescriptor c -> m PluginConfig getPluginConfig plugin = do-    config <- getClientConfig-    return $ configForPlugin config plugin+  config <- getClientConfig+  return $ configForPlugin config plugin  -- --------------------------------------------------------------------- @@ -225,24 +232,33 @@  -- --------------------------------------------------------------------- -extractRange :: Range -> T.Text -> T.Text-extractRange (Range (Position sl _) (Position el _)) s = newS-  where focusLines = take (fromIntegral $ el-sl+1) $ drop (fromIntegral sl) $ T.lines s-        newS = T.unlines focusLines+-- | Extracts exact matching text in the range.+extractTextInRange :: Range -> T.Text -> T.Text+extractTextInRange (Range (Position sl sc) (Position el ec)) s = newS+  where+    focusLines = take (fromIntegral $ el - sl + 1) $ drop (fromIntegral sl) $ T.lines s+    -- NOTE: We have to trim the last line first to handle the single-line case+    newS =+      focusLines+        & _last %~ T.take (fromIntegral ec)+        & _head %~ T.drop (fromIntegral sc)+        -- NOTE: We cannot use unlines here, because we don't want to add trailing newline!+        & T.intercalate "\n"  -- | Gets the range that covers the entire text fullRange :: T.Text -> Range fullRange s = Range startPos endPos-  where startPos = Position 0 0-        endPos = Position lastLine 0-        {--        In order to replace everything including newline characters,-        the end range should extend below the last line. From the specification:-        "If you want to specify a range that contains a line including-        the line ending character(s) then use an end position denoting-        the start of the next line"-        -}-        lastLine = fromIntegral $ length $ T.lines s+  where+    startPos = Position 0 0+    endPos = Position lastLine 0+    {-+    In order to replace everything including newline characters,+    the end range should extend below the last line. From the specification:+    "If you want to specify a range that contains a line including+    the line ending character(s) then use an end position denoting+    the start of the next line"+    -}+    lastLine = fromIntegral $ length $ T.lines s  subRange :: Range -> Range -> Bool subRange = isSubrangeOf@@ -251,40 +267,16 @@  allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text] allLspCmdIds' pid (IdePlugins ls) =-    allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls+  allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls  allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text] allLspCmdIds pid commands = concatMap go commands   where     go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds - -- --------------------------------------------------------------------- -getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath-getNormalizedFilePath uri = handleMaybe errMsg-        $ uriToNormalizedFilePath-        $ toNormalizedUri uri-    where-        errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath" --- ----------------------------------------------------------------------throwPluginError :: Monad m => String -> ExceptT String m b-throwPluginError = throwE--handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b-handleMaybe msg = maybe (throwE msg) return--handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b-handleMaybeM msg act = maybeM (throwE msg) return $ lift act--pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a)-pluginResponse =-  fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))-    . runExceptT---- ---------------------------------------------------------------------- type TextParser = P.Parsec Void T.Text  -- | Unescape printable escape sequences within double quotes.@@ -292,9 +284,9 @@ -- display as is. unescape :: T.Text -> T.Text unescape input =-    case P.runParser escapedTextParser "inline" input of-        Left _     -> input-        Right strs -> T.pack strs+  case P.runParser escapedTextParser "inline" input of+    Left _     -> input+    Right strs -> T.pack strs  -- | Parser for a string that contains double quotes. Returns unescaped string. escapedTextParser :: TextParser String@@ -305,11 +297,11 @@      stringLiteral :: TextParser String     stringLiteral = do-        inside <- P.char '"' >> P.manyTill P.charLiteral (P.char '"')-        let f '"' = "\\\"" -- double quote should still be escaped-            -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable-            -- characters. So we need to call 'isPrint' from 'Data.Char' manually.-            f ch  = if isPrint ch then [ch] else showLitChar ch ""-            inside' = concatMap f inside+      inside <- P.char '"' >> P.manyTill P.charLiteral (P.char '"')+      let f '"' = "\\\"" -- double quote should still be escaped+      -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable+      -- characters. So we need to call 'isPrint' from 'Data.Char' manually.+          f ch  = if isPrint ch then [ch] else showLitChar ch ""+          inside' = concatMap f inside -        pure $ "\"" <> inside' <> "\""+      pure $ "\"" <> inside' <> "\""

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE BlockArguments             #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DefaultSignatures          #-}@@ -9,8 +10,10 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MonadComprehensions        #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedLabels           #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE PatternSynonyms            #-} {-# LANGUAGE PolyKinds                  #-}@@ -19,7 +22,6 @@ {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE ViewPatterns               #-}- module Ide.Types ( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor , defaultPluginPriority@@ -45,71 +47,65 @@ , PluginRequestMethod(..) , getProcessID, getPid , installSigUsr1Handler-, responseError , lookupCommandProvider+, ResolveFunction+, mkResolveHandler )     where  #ifdef mingw32_HOST_OS-import qualified System.Win32.Process            as P (getCurrentProcessId)++import qualified System.Win32.Process          as P (getCurrentProcessId)+ #else-import           Control.Monad                   (void)-import qualified System.Posix.Process            as P (getProcessID)++import qualified System.Posix.Process          as P (getProcessID) import           System.Posix.Signals+ #endif-import           Control.Applicative             ((<|>))-import           Control.Arrow                   ((&&&))-import           Control.Lens                    ((.~), (^.))-import           Data.Aeson                      hiding (defaultOptions)++import           Control.Applicative           ((<|>))+import           Control.Arrow                 ((&&&))+import           Control.Lens                  (_Just, (.~), (?~), (^.), (^?))+import           Control.Monad                 (void)+import           Control.Monad.Error.Class     (MonadError (throwError))+import           Control.Monad.Trans.Class     (MonadTrans (lift))+import           Control.Monad.Trans.Except    (ExceptT, runExceptT)+import           Data.Aeson                    hiding (Null, defaultOptions) import           Data.Default-import           Data.Dependent.Map              (DMap)-import qualified Data.Dependent.Map              as DMap-import qualified Data.DList                      as DList+import           Data.Dependent.Map            (DMap)+import qualified Data.Dependent.Map            as DMap+import qualified Data.DList                    as DList import           Data.GADT.Compare-import           Data.Hashable                   (Hashable)-import           Data.HashMap.Strict             (HashMap)-import qualified Data.HashMap.Strict             as HashMap-import           Data.List.Extra                 (find, sortOn)-import           Data.List.NonEmpty              (NonEmpty (..), toList)-import qualified Data.Map                        as Map+import           Data.Hashable                 (Hashable)+import           Data.HashMap.Strict           (HashMap)+import qualified Data.HashMap.Strict           as HashMap+import           Data.Kind                     (Type)+import           Data.List.Extra               (find, sortOn)+import           Data.List.NonEmpty            (NonEmpty (..), toList)+import qualified Data.Map                      as Map import           Data.Maybe import           Data.Ord import           Data.Semigroup import           Data.String-import qualified Data.Text                       as T-import           Data.Text.Encoding              (encodeUtf8)+import qualified Data.Text                     as T+import           Data.Text.Encoding            (encodeUtf8) import           Development.IDE.Graph-import           GHC                             (DynFlags)+import           GHC                           (DynFlags) import           GHC.Generics+import           Ide.Plugin.Error import           Ide.Plugin.Properties-import           Language.LSP.Server             (LspM, getVirtualFile)-import           Language.LSP.Types              hiding-                                                 (SemanticTokenAbsolute (length, line),-                                                  SemanticTokenRelative (length),-                                                  SemanticTokensEdit (_start))-import           Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities),-                                                  TextDocumentClientCapabilities (_codeAction, _documentSymbol))-import           Language.LSP.Types.Lens         as J (HasChildren (children),-                                                       HasCommand (command),-                                                       HasContents (contents),-                                                       HasDeprecated (deprecated),-                                                       HasEdit (edit),-                                                       HasKind (kind),-                                                       HasName (name),-                                                       HasOptions (..),-                                                       HasRange (range),-                                                       HasTextDocument (..),-                                                       HasTitle (title),-                                                       HasUri (..))-import qualified Language.LSP.Types.Lens         as J+import qualified Language.LSP.Protocol.Lens    as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server           (LspM, LspT, getVirtualFile) import           Language.LSP.VFS import           Numeric.Natural import           OpenTelemetry.Eventlog-import           Options.Applicative             (ParserInfo)+import           Options.Applicative           (ParserInfo) import           System.FilePath import           System.IO.Unsafe-import           Text.Regex.TDFA.Text            ()-+import           Text.Regex.TDFA.Text          () -- ---------------------------------------------------------------------  data IdePlugins ideState = IdePlugins_@@ -170,7 +166,7 @@  -- | We (initially anyway) mirror the hie configuration, so that existing -- clients can simply switch executable and not have any nasty surprises.  There--- will be surprises relating to config options being ignored, initially though.+-- will initially be surprises relating to config options being ignored though. data Config =   Config     { checkParents            :: CheckParents@@ -200,6 +196,7 @@     -- , formattingProvider          = "floskell"     -- , formattingProvider          = "stylish-haskell"     , cabalFormattingProvider     = "cabal-fmt"+    -- this string value needs to kept in sync with the value provided in HlsPlugins     , maxCompletions              = 40     , plugins                     = mempty     }@@ -268,7 +265,7 @@  -- --------------------------------------------------------------------- -data PluginDescriptor (ideState :: *) =+data PluginDescriptor (ideState :: Type) =   PluginDescriptor { pluginId           :: !PluginId                    -- ^ Unique identifier of the plugin.                    , pluginPriority     :: Natural@@ -282,7 +279,7 @@                    , pluginCli            :: Maybe (ParserInfo (IdeCommand ideState))                    , pluginFileType       :: [T.Text]                    -- ^ File extension of the files the plugin is responsible for.-                   --   The plugin is only allowed to handle files with these extensions+                   --   The plugin is only allowed to handle files with these extensions.                    --   When writing handlers, etc. for this plugin it can be assumed that all handled files are of this type.                    --   The file extension must have a leading '.'.                    }@@ -301,8 +298,8 @@ -- | An existential wrapper of 'Properties' data CustomConfig = forall r. CustomConfig (Properties r) --- | Describes the configuration a plugin.--- A plugin may be configurable in such form:+-- | Describes the configuration of a plugin.+-- A plugin may be configurable as can be seen below: -- -- @ -- {@@ -317,7 +314,7 @@ -- } -- @ ----- @globalOn@, @codeActionsOn@, and @codeLensOn@ etc. are called generic configs,+-- @globalOn@, @codeActionsOn@, and @codeLensOn@ etc. are called generic configs -- which can be inferred from handlers registered by the plugin. -- @config@ is called custom config, which is defined using 'Properties'. data ConfigDescriptor = ConfigDescriptor {@@ -341,393 +338,431 @@ -- | Methods that can be handled by plugins. -- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method -- Only methods for which we know how to combine responses can be instances of 'PluginMethod'-class HasTracing (MessageParams m) => PluginMethod (k :: MethodType) (m :: Method FromClient k) where+class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Method ClientToServer k) where    -- | Parse the configuration to check if this plugin is enabled.-  -- Perform sanity checks on the message to see whether plugin is enabled+  -- Perform sanity checks on the message to see whether the plugin is enabled   -- for this message in particular.-  -- If a plugin is not enabled, its handlers, commands, etc... will not be+  -- If a plugin is not enabled, its handlers, commands, etc. will not be   -- run for the given message.   ---  -- Semantically, this method described whether a Plugin is enabled configuration wise+  -- Semantically, this method describes whether a plugin is enabled configuration wise   -- and is allowed to respond to the message. This might depend on the URI that is-  -- associated to the Message Parameters, but doesn't have to. There are requests-  -- with no associated URI that, consequentially, can't inspect the URI.+  -- associated to the Message Parameters. There are requests+  -- with no associated URI that, consequentially, cannot inspect the URI.   ---  -- Common reason why a plugin might not be allowed to respond although it is enabled:-  --   * Plugin can not handle requests associated to the specific URI+  -- A common reason why a plugin might not be allowed to respond although it is enabled:+  --   * The plugin cannot handle requests associated with the specific URI   --     * Since the implementation of [cabal plugins](https://github.com/haskell/haskell-language-server/issues/2940)-  --       HLS knows plugins specific for Haskell and specific for [Cabal file descriptions](https://cabal.readthedocs.io/en/3.6/cabal-package.html)+  --       HLS knows plugins specific to Haskell and specific to [Cabal file descriptions](https://cabal.readthedocs.io/en/3.6/cabal-package.html)   --   -- Strictly speaking, we are conflating two concepts here:-  --   * Dynamically enabled (e.g. enabled on a per-message basis)+  --   * Dynamically enabled (e.g. on a per-message basis)   --   * Statically enabled (e.g. by configuration in the lsp-client)   --     * Strictly speaking, this might also change dynamically   ---  -- But there is no use to split it up currently into two different methods for now.+  -- But there is no use to split it up into two different methods for now.   pluginEnabled     :: SMethod m     -- ^ Method type.     -> MessageParams m     -- ^ Whether a plugin is enabled might depend on the message parameters-    --   eg 'pluginFileType' specifies what file extension a plugin is allowed to handle+    --   e.g. 'pluginFileType' specifies which file extensions a plugin is allowed to handle     -> PluginDescriptor c-    -- ^ Contains meta information such as PluginId and what file types this+    -- ^ Contains meta information such as PluginId and which file types this     -- plugin is able to handle.     -> Config-    -- ^ Generic config description, expected to hold 'PluginConfig' configuration+    -- ^ Generic config description, expected to contain 'PluginConfig' configuration     -- for this plugin     -> Bool     -- ^ Is this plugin enabled and allowed to respond to the given request     -- with the given parameters? -  default pluginEnabled :: (HasTextDocument (MessageParams m) doc, HasUri doc Uri)+  default pluginEnabled :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)                               => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool   pluginEnabled _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf desc)     where-        uri = params ^. J.textDocument . J.uri+        uri = params ^. L.textDocument . L.uri  -- --------------------------------------------------------------------- -- Plugin Requests -- --------------------------------------------------------------------- -class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient Request) where+class PluginMethod Request m => PluginRequestMethod (m :: Method ClientToServer Request) where   -- | How to combine responses from different plugins.   --   -- For example, for Hover requests, we might have multiple producers of-  -- Hover information, we do not want to decide which one to display to the user-  -- but allow here to define how to merge two hover request responses into one+  -- Hover information. We do not want to decide which one to display to the user+  -- but instead allow to define how to merge two hover request responses into one   -- glorious hover box.   ---  -- However, sometimes only one handler of a request can realistically exist,-  -- such as TextDocumentFormatting, it is safe to just unconditionally report+  -- However, as sometimes only one handler of a request can realistically exist+  -- (such as TextDocumentFormatting), it is safe to just unconditionally report   -- back one arbitrary result (arbitrary since it should only be one anyway).   combineResponses     :: SMethod m     -> Config -- ^ IDE Configuration     -> ClientCapabilities     -> MessageParams m-    -> NonEmpty (ResponseResult m) -> ResponseResult m+    -> NonEmpty (MessageResult m) -> MessageResult m -  default combineResponses :: Semigroup (ResponseResult m)-    => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m+  default combineResponses :: Semigroup (MessageResult m)+    => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (MessageResult m) -> MessageResult m   combineResponses _method _config _caps _params = sconcat -instance PluginMethod Request TextDocumentCodeAction where+instance PluginMethod Request Method_TextDocumentCodeAction where   pluginEnabled _ msgParams pluginDesc config =     pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)     where-      uri = msgParams ^. J.textDocument . J.uri--instance PluginRequestMethod TextDocumentCodeAction where-  combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _) (CodeActionParams _ _ _ _ context) resps =-      fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps-    where-      compat :: (Command |? CodeAction) -> (Command |? CodeAction)-      compat x@(InL _) = x-      compat x@(InR action)-        | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport-        = x-        | otherwise = InL cmd-        where-          cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)-          cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]+      uri = msgParams ^. L.textDocument . L.uri -      wasRequested :: (Command |? CodeAction) -> Bool-      wasRequested (InL _) = True-      wasRequested (InR ca)-        | Nothing <- _only context = True-        | Just (List allowed) <- _only context-        -- See https://github.com/microsoft/language-server-protocol/issues/970-        -- This is somewhat vague, but due to the hierarchical nature of action kinds, we-        -- should check whether the requested kind is a *prefix* of the action kind.-        -- That means, for example, we will return actions with kinds `quickfix.import` and-        -- `quickfix.somethingElse` if the requested kind is `quickfix`.-        , Just caKind <- ca ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed-        | otherwise = False+instance PluginMethod Request Method_CodeActionResolve where+  -- See Note [Resolve in PluginHandlers]+  pluginEnabled _ msgParams pluginDesc config =+    pluginResolverResponsible (msgParams ^. L.data_) pluginDesc+    && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) -instance PluginMethod Request TextDocumentDefinition where+instance PluginMethod Request Method_TextDocumentDefinition where   pluginEnabled _ msgParams pluginDesc _ =     pluginResponsible uri pluginDesc     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentTypeDefinition where+instance PluginMethod Request Method_TextDocumentTypeDefinition where   pluginEnabled _ msgParams pluginDesc _ =     pluginResponsible uri pluginDesc     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentDocumentHighlight where+instance PluginMethod Request Method_TextDocumentDocumentHighlight where   pluginEnabled _ msgParams pluginDesc _ =     pluginResponsible uri pluginDesc     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentReferences where+instance PluginMethod Request Method_TextDocumentReferences where   pluginEnabled _ msgParams pluginDesc _ =     pluginResponsible uri pluginDesc     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request WorkspaceSymbol where+instance PluginMethod Request Method_WorkspaceSymbol where   -- Unconditionally enabled, but should it really be?   pluginEnabled _ _ _ _ = True -instance PluginMethod Request TextDocumentCodeLens where+instance PluginMethod Request Method_TextDocumentCodeLens where   pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentRename where+instance PluginMethod Request Method_CodeLensResolve where+  -- See Note [Resolve in PluginHandlers]+  pluginEnabled _ msgParams pluginDesc config =+    pluginResolverResponsible (msgParams ^. L.data_) pluginDesc+    && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)++instance PluginMethod Request Method_TextDocumentRename where   pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc)    where-      uri = msgParams ^. J.textDocument . J.uri-instance PluginMethod Request TextDocumentHover where+      uri = msgParams ^. L.textDocument . L.uri+instance PluginMethod Request Method_TextDocumentHover where   pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcHoverOn (configForPlugin config pluginDesc)    where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentDocumentSymbol where+instance PluginMethod Request Method_TextDocumentDocumentSymbol where   pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcSymbolsOn (configForPlugin config pluginDesc)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request CompletionItemResolve where-  pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc)+instance PluginMethod Request Method_CompletionItemResolve where+  -- See Note [Resolve in PluginHandlers]+  pluginEnabled _ msgParams pluginDesc config = pluginResolverResponsible (msgParams ^. L.data_) pluginDesc+    && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) -instance PluginMethod Request TextDocumentCompletion where+instance PluginMethod Request Method_TextDocumentCompletion where   pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentFormatting where-  pluginEnabled STextDocumentFormatting msgParams pluginDesc conf =+instance PluginMethod Request Method_TextDocumentFormatting where+  pluginEnabled SMethod_TextDocumentFormatting msgParams pluginDesc conf =     pluginResponsible uri pluginDesc       && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri       pid = pluginId pluginDesc -instance PluginMethod Request TextDocumentRangeFormatting where+instance PluginMethod Request Method_TextDocumentRangeFormatting where   pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc       && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri       pid = pluginId pluginDesc -instance PluginMethod Request TextDocumentPrepareCallHierarchy where+instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where   pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentSelectionRange where+instance PluginMethod Request Method_TextDocumentSelectionRange where   pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcSelectionRangeOn (configForPlugin conf pluginDesc)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentFoldingRange where+instance PluginMethod Request Method_TextDocumentFoldingRange where   pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc       && pluginEnabledConfig plcFoldingRangeOn (configForPlugin conf pluginDesc)     where-      uri = msgParams ^. J.textDocument . J.uri+      uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request CallHierarchyIncomingCalls where+instance PluginMethod Request Method_CallHierarchyIncomingCalls where   -- This method has no URI parameter, thus no call to 'pluginResponsible'   pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) -instance PluginMethod Request CallHierarchyOutgoingCalls where+instance PluginMethod Request Method_CallHierarchyOutgoingCalls where   -- This method has no URI parameter, thus no call to 'pluginResponsible'   pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) -instance PluginMethod Request CustomMethod where+instance PluginMethod Request (Method_CustomMethod m) where   pluginEnabled _ _ _ _ = True  ----instance PluginRequestMethod TextDocumentDefinition where+instance PluginRequestMethod Method_TextDocumentCodeAction where+  combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps =+      InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps+    where+      compat :: (Command |? CodeAction) -> (Command |? CodeAction)+      compat x@(InL _) = x+      compat x@(InR action)+        | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport+        = x+        | otherwise = InL cmd+        where+          cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams)+          cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))]++      wasRequested :: (Command |? CodeAction) -> Bool+      wasRequested (InL _) = True+      wasRequested (InR ca)+        | Nothing <- _only context = True+        | Just allowed <- _only context+        -- See https://github.com/microsoft/language-server-protocol/issues/970+        -- This is somewhat vague, but due to the hierarchical nature of action kinds, we+        -- should check whether the requested kind is a *prefix* of the action kind.+        -- That means, for example, we will return actions with kinds `quickfix.import` and+        -- `quickfix.somethingElse` if the requested kind is `quickfix`.+        , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed+        | otherwise = False++instance PluginRequestMethod Method_CodeActionResolve where+    -- A resolve request should only have one response.+    -- See Note [Resolve in PluginHandlers].+    combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentDefinition where   combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentTypeDefinition where+instance PluginRequestMethod Method_TextDocumentTypeDefinition where   combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentDocumentHighlight where+instance PluginRequestMethod Method_TextDocumentDocumentHighlight where -instance PluginRequestMethod TextDocumentReferences where+instance PluginRequestMethod Method_TextDocumentReferences where -instance PluginRequestMethod WorkspaceSymbol where+instance PluginRequestMethod Method_WorkspaceSymbol where+    -- TODO: combine WorkspaceSymbol. Currently all WorkspaceSymbols are dumped+    -- as it is new of lsp-types 2.0.0.0+    combineResponses _ _ _ _ xs = InL $ mconcat $ takeLefts $ toList xs -instance PluginRequestMethod TextDocumentCodeLens where+instance PluginRequestMethod Method_TextDocumentCodeLens where -instance PluginRequestMethod TextDocumentRename where+instance PluginRequestMethod Method_CodeLensResolve where+    -- A resolve request should only ever get one response.+    -- See note Note [Resolve in PluginHandlers]+    combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentHover where-  combineResponses _ _ _ _ (catMaybes . toList -> hs) = h+instance PluginRequestMethod Method_TextDocumentRename where++instance PluginRequestMethod Method_TextDocumentHover where+  combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> hs :: [Hover]) =+    if null hs+        then InR Null+        else InL $ Hover (InL mcontent) r     where-      r = listToMaybe $ mapMaybe (^. range) hs-      h = case foldMap (^. contents) hs of-            HoverContentsMS (List []) -> Nothing-            hh                        -> Just $ Hover hh r+      r = listToMaybe $ mapMaybe (^. L.range) hs+      -- We are only taking MarkupContent here, because MarkedStrings have been+      -- deprecated for a while and don't occur in the hls codebase+      mcontent :: MarkupContent+      mcontent = mconcat $ takeLefts $ map (^. L.contents) hs -instance PluginRequestMethod TextDocumentDocumentSymbol where-  combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res+instance PluginRequestMethod Method_TextDocumentDocumentSymbol where+  combineResponses _ _ (ClientCapabilities _ tdc _ _ _ _) params xs = res     where-      uri' = params ^. textDocument . uri+      uri' = params ^. L.textDocument . L.uri       supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport)-      dsOrSi = fmap toEither xs+      dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]]+      dsOrSi =  toEither <$> mapMaybe nullToMaybe' (toList xs)+      res :: [SymbolInformation] |? ([DocumentSymbol] |? Null)       res-        | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi-        | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi-      siToDs (SymbolInformation name kind _tags dep (Location _uri range) cont)+        | supportsHierarchy = InR $ InL $ concatMap (either (fmap siToDs) id) dsOrSi+        | otherwise = InL $ concatMap (either id ( concatMap dsToSi)) dsOrSi+      -- Is this actually a good conversion? It's what there was before, but some+      -- things such as tags are getting lost+      siToDs :: SymbolInformation -> DocumentSymbol+      siToDs (SymbolInformation name kind _tags cont dep (Location _uri range) )         = DocumentSymbol name cont kind Nothing dep range range Nothing       dsToSi = go Nothing       go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]       go parent ds =         let children' :: [SymbolInformation]-            children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children))-            loc = Location uri' (ds ^. range)-            name' = ds ^. name-            si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent+            children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. L.children))+            loc = Location uri' (ds ^. L.range)+            name' = ds ^. L.name+            si = SymbolInformation name' (ds ^. L.kind) Nothing parent (ds ^. L.deprecated) loc         in [si] <> children' -instance PluginRequestMethod CompletionItemResolve where-  -- resolving completions can only change the detail, additionalTextEdit or documentation fields-  combineResponses _ _ _ _ (x :| xs) = go x xs-    where go :: CompletionItem -> [CompletionItem] -> CompletionItem-          go !comp [] = comp-          go !comp1 (comp2:xs)-            = go (comp1-                 & J.detail              .~ comp1 ^. J.detail <> comp2 ^. J.detail-                 & J.documentation       .~ ((comp1 ^. J.documentation) <|> (comp2 ^. J.documentation)) -- difficult to write generic concatentation for docs-                 & J.additionalTextEdits .~ comp1 ^. J.additionalTextEdits <> comp2 ^. J.additionalTextEdits)-                 xs+instance PluginRequestMethod Method_CompletionItemResolve where+  -- A resolve request should only have one response.+  -- See Note [Resolve in PluginHandlers]+  combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentCompletion where+instance PluginRequestMethod Method_TextDocumentCompletion where   combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs       where         limit = maxCompletions conf-        combine :: [List CompletionItem |? CompletionList] -> (List CompletionItem |? CompletionList)+        combine :: [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null))         combine cs = go True mempty cs +        go :: Bool -> DList.DList CompletionItem -> [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null))         go !comp acc [] =-          InR (CompletionList comp (List $ DList.toList acc))-        go comp acc (InL (List ls) : rest) =+           InR (InL (CompletionList comp Nothing ( DList.toList acc)))+        go comp acc ((InL ls) : rest) =           go comp (acc <> DList.fromList ls) rest-        go comp acc (InR (CompletionList comp' (List ls)) : rest) =+        go comp acc ( (InR (InL (CompletionList comp' _ ls))) : rest) =           go (comp && comp') (acc <> DList.fromList ls) rest-+        go comp acc ( (InR (InR Null)) : rest) =+          go comp acc rest         -- boolean disambiguators         isCompleteResponse, isIncompleteResponse :: Bool         isIncompleteResponse = True         isCompleteResponse = False--        consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) =+        consumeCompletionResponse :: Int -> ([CompletionItem] |? (CompletionList |? Null)) -> (Int, [CompletionItem] |? (CompletionList |? Null))+        consumeCompletionResponse limit it@(InR (InL (CompletionList _ _ xx))) =           case splitAt limit xx of             -- consumed all the items, return the result as is             (_, []) -> (limit - length xx, it)             -- need to crop the response, set the 'isIncomplete' flag-            (xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx')))-        consumeCompletionResponse n (InL (List xx)) =-          consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))--instance PluginRequestMethod TextDocumentFormatting where+            (xx', _) -> (0, InR (InL (CompletionList isIncompleteResponse Nothing xx')))+        consumeCompletionResponse n (InL xx) =+          consumeCompletionResponse n (InR (InL (CompletionList isCompleteResponse Nothing xx)))+        consumeCompletionResponse n (InR (InR Null)) = (n, InR (InR Null))+instance PluginRequestMethod Method_TextDocumentFormatting where   combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentRangeFormatting where+instance PluginRequestMethod Method_TextDocumentRangeFormatting where   combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentPrepareCallHierarchy where+instance PluginRequestMethod Method_TextDocumentPrepareCallHierarchy where -instance PluginRequestMethod TextDocumentSelectionRange where+instance PluginRequestMethod Method_TextDocumentSelectionRange where   combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentFoldingRange where+instance PluginRequestMethod Method_TextDocumentFoldingRange where   combineResponses _ _ _ _ x = sconcat x -instance PluginRequestMethod CallHierarchyIncomingCalls where+instance PluginRequestMethod Method_CallHierarchyIncomingCalls where -instance PluginRequestMethod CallHierarchyOutgoingCalls where+instance PluginRequestMethod Method_CallHierarchyOutgoingCalls where -instance PluginRequestMethod CustomMethod where+instance PluginRequestMethod (Method_CustomMethod m) where   combineResponses _ _ _ _ (x :| _) = x +takeLefts :: [a |? b] -> [a]+takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x])++nullToMaybe' :: (a |? (b |? Null)) -> Maybe (a |? b)+nullToMaybe' (InL x)       = Just $ InL x+nullToMaybe' (InR (InL x)) = Just $ InR x+nullToMaybe' (InR (InR _)) = Nothing -- --------------------------------------------------------------------- -- Plugin Notifications -- ---------------------------------------------------------------------  -- | Plugin Notification methods. No specific methods at the moment, but -- might contain more in the future.-class PluginMethod Notification m => PluginNotificationMethod (m :: Method FromClient Notification)  where+class PluginMethod Notification m => PluginNotificationMethod (m :: Method ClientToServer Notification)  where  -instance PluginMethod Notification TextDocumentDidOpen where+instance PluginMethod Notification Method_TextDocumentDidOpen where -instance PluginMethod Notification TextDocumentDidChange where+instance PluginMethod Notification Method_TextDocumentDidChange where -instance PluginMethod Notification TextDocumentDidSave where+instance PluginMethod Notification Method_TextDocumentDidSave where -instance PluginMethod Notification TextDocumentDidClose where+instance PluginMethod Notification Method_TextDocumentDidClose where -instance PluginMethod Notification WorkspaceDidChangeWatchedFiles where+instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where   -- This method has no URI parameter, thus no call to 'pluginResponsible'.   pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc -instance PluginMethod Notification WorkspaceDidChangeWorkspaceFolders where+instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where   -- This method has no URI parameter, thus no call to 'pluginResponsible'.   pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc -instance PluginMethod Notification WorkspaceDidChangeConfiguration where+instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where   -- This method has no URI parameter, thus no call to 'pluginResponsible'.   pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc -instance PluginMethod Notification Initialized where+instance PluginMethod Notification Method_Initialized where   -- This method has no URI parameter, thus no call to 'pluginResponsible'.   pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc  -instance PluginNotificationMethod TextDocumentDidOpen where+instance PluginNotificationMethod Method_TextDocumentDidOpen where -instance PluginNotificationMethod TextDocumentDidChange where+instance PluginNotificationMethod Method_TextDocumentDidChange where -instance PluginNotificationMethod TextDocumentDidSave where+instance PluginNotificationMethod Method_TextDocumentDidSave where -instance PluginNotificationMethod TextDocumentDidClose where+instance PluginNotificationMethod Method_TextDocumentDidClose where -instance PluginNotificationMethod WorkspaceDidChangeWatchedFiles where+instance PluginNotificationMethod Method_WorkspaceDidChangeWatchedFiles where -instance PluginNotificationMethod WorkspaceDidChangeWorkspaceFolders where+instance PluginNotificationMethod Method_WorkspaceDidChangeWorkspaceFolders where -instance PluginNotificationMethod WorkspaceDidChangeConfiguration where+instance PluginNotificationMethod Method_WorkspaceDidChangeConfiguration where -instance PluginNotificationMethod Initialized where+instance PluginNotificationMethod Method_Initialized where  -- ---------------------------------------------------------------------  -- | Methods which have a PluginMethod instance-data IdeMethod (m :: Method FromClient Request) = PluginRequestMethod m => IdeMethod (SMethod m)+data IdeMethod (m :: Method ClientToServer Request) = PluginRequestMethod m => IdeMethod (SMethod m) instance GEq IdeMethod where   geq (IdeMethod a) (IdeMethod b) = geq a b instance GCompare IdeMethod where   gcompare (IdeMethod a) (IdeMethod b) = gcompare a b  -- | Methods which have a PluginMethod instance-data IdeNotification (m :: Method FromClient Notification) = PluginNotificationMethod m => IdeNotification (SMethod m)+data IdeNotification (m :: Method ClientToServer Notification) = PluginNotificationMethod m => IdeNotification (SMethod m) instance GEq IdeNotification where   geq (IdeNotification a) (IdeNotification b) = geq a b instance GCompare IdeNotification where   gcompare (IdeNotification a) (IdeNotification b) = gcompare a b  -- | Combine handlers for the-newtype PluginHandler a (m :: Method FromClient Request)-  = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))+newtype PluginHandler a (m :: Method ClientToServer Request)+  = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either PluginError (MessageResult m)))) -newtype PluginNotificationHandler a (m :: Method FromClient Notification)+newtype PluginNotificationHandler a (m :: Method ClientToServer Notification)   = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())  newtype PluginHandlers a             = PluginHandlers             (DMap IdeMethod       (PluginHandler a))@@ -750,24 +785,51 @@ instance Monoid (PluginNotificationHandlers a) where   mempty = PluginNotificationHandlers mempty -type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))+type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM Config) (MessageResult m)  type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () --- | Make a handler for plugins with no extra data+-- | Make a handler for plugins. For how resolve works with this see+-- Note [Resolve in PluginHandlers] mkPluginHandler-  :: PluginRequestMethod m+  :: forall ideState m. PluginRequestMethod m   => SClientMethod m   -> PluginMethodHandler ideState m   -> PluginHandlers ideState-mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f')+mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m))   where-    f' pid ide params = pure <$> f ide pid params+    f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either PluginError (MessageResult m)))+    -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions+    -- CodeLens, and Completion methods.+    f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} =+      pure . fmap (wrapCodeActions pid _uri) <$> runExceptT (f ide pid params)+    f' SMethod_TextDocumentCodeLens pid ide params@CodeLensParams{_textDocument=TextDocumentIdentifier {_uri}} =+      pure . fmap (wrapCodeLenses pid _uri) <$> runExceptT (f ide pid params)+    f' SMethod_TextDocumentCompletion pid ide params@CompletionParams{_textDocument=TextDocumentIdentifier {_uri}} =+      pure . fmap (wrapCompletions pid _uri) <$> runExceptT (f ide pid params) +    -- This is the default case for all other methods+    f' _ pid ide params = pure <$> runExceptT (f ide pid params)++    -- Todo: use fancy pancy lenses to make this a few lines+    wrapCodeActions pid uri (InL ls) =+      let wrapCodeActionItem pid uri (InR c) = InR $ wrapResolveData pid uri c+          wrapCodeActionItem _ _ command@(InL _) = command+      in InL $ wrapCodeActionItem pid uri <$> ls+    wrapCodeActions _ _ (InR r) = InR r++    wrapCodeLenses pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls+    wrapCodeLenses _ _ (InR r)      = InR r++    wrapCompletions pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls+    wrapCompletions pid uri (InR (InL cl@(CompletionList{_items}))) =+      InR $ InL $ cl & L.items .~ (wrapResolveData pid uri <$> _items)+    wrapCompletions _ _ (InR (InR r)) = InR $ InR r+ -- | Make a handler for plugins with no extra data mkPluginNotificationHandler   :: PluginNotificationMethod m-  => SClientMethod (m :: Method FromClient Notification)+  => SClientMethod (m :: Method ClientToServer Notification)   -> PluginNotificationMethodHandler ideState m   -> PluginNotificationHandlers ideState mkPluginNotificationHandler m f@@ -779,7 +841,7 @@ defaultPluginPriority = 1000  -- | Set up a plugin descriptor, initialized with default values.--- This is plugin descriptor is prepared for @haskell@ files, such as+-- This plugin descriptor is prepared for @haskell@ files, such as -- --   * @.hs@ --   * @.lhs@@@ -802,7 +864,7 @@     [".hs", ".lhs", ".hs-boot"]  -- | Set up a plugin descriptor, initialized with default values.--- This is plugin descriptor is prepared for @.cabal@ files and as such,+-- This plugin descriptor is prepared for @.cabal@ files and as such, -- will only respond / run when @.cabal@ files are currently in scope. -- -- Handles files with the following extensions:@@ -837,13 +899,69 @@ type CommandFunction ideState a   = ideState   -> a-  -> LspM Config (Either ResponseError Value)+  -> ExceptT PluginError (LspM Config) (Value |? Null)  -- --------------------------------------------------------------------- +type ResolveFunction ideState a (m :: Method ClientToServer Request) =+  ideState+  -> PluginId+  -> MessageParams m+  -> Uri+  -> a+  -> ExceptT PluginError (LspM Config) (MessageResult m)++-- | Make a handler for resolve methods. In here we take your provided ResolveFunction+-- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers]+mkResolveHandler+  :: forall ideState a m. (FromJSON a,  PluginRequestMethod m, L.HasData_ (MessageParams m) (Maybe Value))+  =>  SClientMethod m+  -> ResolveFunction ideState a m+  -> PluginHandlers ideState+mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do+  case fromJSON <$> (params ^. L.data_) of+    (Just (Success (PluginResolveData owner uri value) )) -> do+      if owner == plId+      then+        case fromJSON value of+          Success decodedValue ->+            let newParams = params & L.data_ ?~ value+            in f ideState plId newParams uri decodedValue+          Error msg ->+            -- We are assuming that if we can't decode the data, that this+            -- request belongs to another resolve handler for this plugin.+            throwError (PluginRequestRefused (T.pack ("Unable to decode payload for handler, assuming that it's for a different handler" <> msg)))+      -- If we are getting an owner that isn't us, this means that there is an+      -- error, as we filter these our in `pluginEnabled`+      else throwError $ PluginInternalError invalidRequest+    -- If we are getting params without a decodable data field, this means that+    -- there is an error, as we filter these our in `pluginEnabled`+    (Just (Error err)) -> throwError $ PluginInternalError (parseError (params ^. L.data_) err)+    -- If there are no params at all, this also means that there is an error,+    -- as this is filtered out in `pluginEnabled`+    _ -> throwError $ PluginInternalError invalidRequest+  where invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!"+        parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err)++wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a+wrapResolveData pid uri hasData =+  hasData & L.data_ .~  (toJSON . PluginResolveData pid uri <$> data_)+  where data_ = hasData ^? L.data_ . _Just++-- |Allow plugins to "own" resolve data, allowing only them to be queried for+-- the resolve action. This design has added flexibility at the cost of nested+-- Value types+data PluginResolveData = PluginResolveData {+  resolvePlugin :: PluginId+, resolveURI    :: Uri+, resolveValue  :: Value+}+  deriving (Generic, Show)+  deriving anyclass (ToJSON, FromJSON)+ newtype PluginId = PluginId T.Text   deriving (Show, Read, Eq, Ord)-  deriving newtype (FromJSON, Hashable)+  deriving newtype (ToJSON, FromJSON, Hashable)  instance IsString PluginId where   fromString = PluginId . T.pack@@ -869,9 +987,9 @@   type FormattingMethod m =-  ( J.HasOptions (MessageParams m) FormattingOptions-  , J.HasTextDocument (MessageParams m) TextDocumentIdentifier-  , ResponseResult m ~ List TextEdit+  ( L.HasOptions (MessageParams m) FormattingOptions+  , L.HasTextDocument (MessageParams m) TextDocumentIdentifier+  , MessageResult m ~ ([TextEdit] |? Null)   )  type FormattingHandler a@@ -880,37 +998,33 @@   -> T.Text   -> NormalizedFilePath   -> FormattingOptions-  -> LspM Config (Either ResponseError (List TextEdit))+  -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)  mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a-mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting)-                      <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting)+mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)+                      <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting)   where     provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m     provider m ide _pid params       | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do-        mf <- getVirtualFile $ toNormalizedUri uri+        mf <- lift $ getVirtualFile $ toNormalizedUri uri         case mf of           Just vf -> do             let typ = case m of-                  STextDocumentFormatting -> FormatText-                  STextDocumentRangeFormatting -> FormatRange (params ^. J.range)-                  _ -> error "mkFormattingHandlers: impossible"+                  SMethod_TextDocumentFormatting -> FormatText+                  SMethod_TextDocumentRangeFormatting -> FormatRange (params ^. L.range)+                  _ -> Prelude.error "mkFormattingHandlers: impossible"             f ide typ (virtualFileText vf) nfp opts-          Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri+          Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri -      | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri+      | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri       where-        uri = params ^. J.textDocument . J.uri-        opts = params ^. J.options+        uri = params ^. L.textDocument . L.uri+        opts = params ^. L.options  -- --------------------------------------------------------------------- -responseError :: T.Text -> ResponseError-responseError txt = ResponseError InvalidParams txt Nothing --- ---------------------------------------------------------------------- data FallbackCodeActionParams =   FallbackCodeActionParams     { fallbackWorkspaceEdit :: Maybe WorkspaceEdit@@ -927,8 +1041,8 @@   traceWithSpan :: SpanInFlight -> a -> IO ()   traceWithSpan _ _ = pure () -instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where-  traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri)+instance {-# OVERLAPPABLE #-} (L.HasTextDocument a doc, L.HasUri doc Uri) => HasTracing a where+  traceWithSpan sp a = otSetUri sp (a ^. L.textDocument . L.uri)  instance HasTracing Value instance HasTracing ExecuteCommandParams@@ -938,24 +1052,29 @@ instance HasTracing DidChangeWorkspaceFoldersParams instance HasTracing DidChangeConfigurationParams instance HasTracing InitializeParams-instance HasTracing (Maybe InitializedParams)+instance HasTracing InitializedParams instance HasTracing WorkspaceSymbolParams where   traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams-instance HasTracing CompletionItem +-- Instances for resolve types+instance HasTracing CodeAction+instance HasTracing CodeLens+instance HasTracing CompletionItem+instance HasTracing DocumentLink+instance HasTracing InlayHint+instance HasTracing WorkspaceSymbol -- ----------------------------------------------------------------------+--Experimental resolve refactoring {-# NOINLINE pROCESS_ID #-} pROCESS_ID :: T.Text pROCESS_ID = unsafePerformIO getPid  mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command-mkLspCommand plid cn title args' = Command title cmdId args+mkLspCommand plid cn title args = Command title cmdId args   where     cmdId = mkLspCmdId pROCESS_ID plid cn-    args = List <$> args'  mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text mkLspCmdId pid (PluginId plid) (CommandId cid)@@ -979,3 +1098,40 @@  installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif++-- |Determine whether this request should be routed to the plugin. Fails closed+-- if we can't determine which plugin it should be routed to.+pluginResolverResponsible :: Maybe Value -> PluginDescriptor c -> Bool+pluginResolverResponsible (Just (fromJSON -> (Success (PluginResolveData o _ _)))) pluginDesc =+  pluginId pluginDesc == o+-- We want to fail closed+pluginResolverResponsible _ _ = False++{- Note [Resolve in PluginHandlers]+  Resolve methods have a few guarantees that need to be made by HLS,+  specifically they need to only be called once, as neither their errors nor+  their responses can be easily combined. Whereas commands, which similarly have+  the same requirements have their own codepaths for execution, for resolve+  methods we are relying on the standard PluginHandlers codepath.+  That isn't a problem, but it does mean we need to do some things extra for+  these methods.+    - First of all, whenever a handler that can be resolved sets the data_ field+    in their response, we need to intercept it, and wrap it in a data type+    PluginResolveData that allows us to route the future resolve request to the+    specific plugin which is responsible for it. (We also throw in the URI for+    convenience, because everyone needs that). We do that in mkPluginHandler.+    - When we get any resolve requests we check their data field for our+    PluginResolveData that will allow us to route the request to the right+    plugin. If we can't find out which plugin to route the request to, then we+    just don't route it at all. This is done in pluginEnabled, and+    pluginResolverResponsible.+    - Finally we have mkResolveHandler, which takes the resolve request and+    unwraps the plugins data from our PluginResolveData, parses it and passes it+    it on to the registered handler.+  It should be noted that there are some restrictions with this approach: First,+  if a plugin does not set the data_ field, than the request will not be able+  to be resolved. This is because we only wrap data_ fields that have been set+  with our PluginResolvableData tag. Second, if a plugin were to register two+  resolve handlers for the same method, than our assumptions that we never have+  two responses break, and behavior is undefined.+  -}

@@ -5,13 +5,13 @@     ( tests     ) where -import           Data.Char             (isPrint)-import qualified Data.Set              as Set-import qualified Data.Text             as T-import qualified Ide.Plugin.RangeMap   as RangeMap-import           Ide.PluginUtils       (positionInRange, unescape)-import           Language.LSP.Types    (Position (..), Range (Range), UInt,-                                        isSubrangeOf)+import           Data.Char                   (isPrint)+import qualified Data.Set                    as Set+import qualified Data.Text                   as T+import qualified Ide.Plugin.RangeMap         as RangeMap+import           Ide.PluginUtils             (positionInRange, unescape)+import           Language.LSP.Protocol.Types (Position (..), Range (Range),+                                              UInt, isSubrangeOf) import           Test.Tasty import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck