diff --git a/hls-plugin-api.cabal b/hls-plugin-api.cabal --- a/hls-plugin-api.cabal +++ b/hls-plugin-api.cabal @@ -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 @@ -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 diff --git a/src/Ide/Logger.hs b/src/Ide/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Logger.hs @@ -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 -> "" + 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 diff --git a/src/Ide/Plugin/ConfigUtils.hs b/src/Ide/Plugin/ConfigUtils.hs --- a/src/Ide/Plugin/ConfigUtils.hs +++ b/src/Ide/Plugin/ConfigUtils.hs @@ -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 diff --git a/src/Ide/Plugin/Error.hs b/src/Ide/Plugin/Error.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Error.hs @@ -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 diff --git a/src/Ide/Plugin/RangeMap.hs b/src/Ide/Plugin/RangeMap.hs --- a/src/Ide/Plugin/RangeMap.hs +++ b/src/Ide/Plugin/RangeMap.hs @@ -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 diff --git a/src/Ide/Plugin/Resolve.hs b/src/Ide/Plugin/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Resolve.hs @@ -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! + -} diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -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' <> "\"" diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -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. + -} diff --git a/test/Ide/PluginUtilsTest.hs b/test/Ide/PluginUtilsTest.hs --- a/test/Ide/PluginUtilsTest.hs +++ b/test/Ide/PluginUtilsTest.hs @@ -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