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.5.0.0 +version: 2.6.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at @@ -38,6 +38,7 @@ Ide.Plugin.Config Ide.Plugin.ConfigUtils Ide.Plugin.Error + Ide.Plugin.HandleRequestTypes Ide.Plugin.Properties Ide.Plugin.RangeMap Ide.Plugin.Resolve @@ -59,7 +60,7 @@ , filepath , ghc , hashable - , hls-graph == 2.5.0.0 + , hls-graph == 2.6.0.0 , lens , lens-aeson , lsp ^>=2.3 diff --git a/src/Ide/Plugin/Config.hs b/src/Ide/Plugin/Config.hs --- a/src/Ide/Plugin/Config.hs +++ b/src/Ide/Plugin/Config.hs @@ -66,6 +66,7 @@ parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <$> o .:? "globalOn" .!= plcGlobalOn def <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def + <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def <*> o .:? "codeLensOn" .!= plcCodeLensOn def <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ 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 @@ -93,6 +93,7 @@ SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] + SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn] _ -> [] -- | Generates json schema used in haskell vscode extension @@ -107,28 +108,29 @@ (PluginId pId) = pluginId genericSchema = let x = - [toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics] - <> nubOrd (mconcat (handlersToGenericSchema <$> handlers)) + [toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" True | configHasDiagnostics] + <> nubOrd (mconcat (handlersToGenericSchema configInitialGenericConfig <$> handlers)) in case x of -- If the plugin has only one capability, we produce globalOn instead of the specific one; -- otherwise we don't produce globalOn at all - [_] -> [toKey' "globalOn" A..= schemaEntry "plugin"] + [_] -> [toKey' "globalOn" A..= schemaEntry "plugin" (plcGlobalOn configInitialGenericConfig)] _ -> x dedicatedSchema = customConfigToDedicatedSchema configCustomConfig - handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of - 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 = + handlersToGenericSchema PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of + SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions" plcCodeActionsOn] + SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses" plcCodeLensOn] + SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename" plcRenameOn] + SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover" plcHoverOn] + SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols" plcSymbolsOn] + SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn] + SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn] + SMethod_TextDocumentSemanticTokensFull -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn] + _ -> [] + schemaEntry desc defaultVal = A.object [ "scope" A..= A.String "resource", "type" A..= A.String "boolean", - "default" A..= True, + "default" A..= A.Bool defaultVal, "description" A..= A.String ("Enables " <> pId <> " " <> desc) ] withIdPrefix x = "haskell.plugin." <> pId <> "." <> x diff --git a/src/Ide/Plugin/Error.hs b/src/Ide/Plugin/Error.hs --- a/src/Ide/Plugin/Error.hs +++ b/src/Ide/Plugin/Error.hs @@ -11,11 +11,12 @@ 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 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 Ide.Plugin.HandleRequestTypes (RejectionReason) import Language.LSP.Protocol.Types -- ---------------------------------------------------------------------------- @@ -79,13 +80,13 @@ | 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 + -- `handlesRequest` decision after receiving the request. This should only be -- used if the decision to accept the request can not be made in - -- `pluginEnabled`. + -- `handlesRequest`. -- -- 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 + -- HLS will respond as if no plugins passed the `handlesRequest` stage. + | PluginRequestRefused RejectionReason -- |PluginRuleFailed should be thrown when a Rule your response depends on -- fails. -- diff --git a/src/Ide/Plugin/HandleRequestTypes.hs b/src/Ide/Plugin/HandleRequestTypes.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/HandleRequestTypes.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.HandleRequestTypes where + +import Data.Text +import Prettyprinter + +-- | Reasons why a plugin could reject a specific request. +data RejectionReason = + -- | The resolve request is not meant for this plugin or handler. The text + -- field should contain the identifier for the plugin who owns this resolve + -- request. + NotResolveOwner Text + -- | The plugin is disabled globally in the users config. + | DisabledGlobally + -- | The feature in the plugin that responds to this request is disabled in + -- the users config + | FeatureDisabled + -- | This plugin is not the formatting provider selected in the users config. + -- The text should be the formatting provider in your config. + | NotFormattingProvider Text + -- | This plugin does not support the file type. The text field here should + -- contain the filetype of the rejected request. + | DoesNotSupportFileType Text + deriving (Eq) + +-- | Whether a plugin will handle a request or not. +data HandleRequestResult = HandlesRequest | DoesNotHandleRequest RejectionReason + deriving (Eq) + +instance Pretty HandleRequestResult where + pretty HandlesRequest = "handles this request" + pretty (DoesNotHandleRequest reason) = pretty reason + +instance Pretty RejectionReason where + pretty (NotResolveOwner s) = "does not handle resolve requests for " <> pretty s <> ")." + pretty DisabledGlobally = "is disabled globally in your config." + pretty FeatureDisabled = "'s feature that handles this request is disabled in your config." + pretty (NotFormattingProvider s) = "is not the formatting provider ("<> pretty s<>") you chose in your config." + pretty (DoesNotSupportFileType s) = "does not support " <> pretty s <> " filetypes)." + +-- We always want to keep the leftmost disabled reason +instance Semigroup HandleRequestResult where + HandlesRequest <> HandlesRequest = HandlesRequest + DoesNotHandleRequest r <> _ = DoesNotHandleRequest r + _ <> DoesNotHandleRequest r = DoesNotHandleRequest r diff --git a/src/Ide/Plugin/Properties.hs b/src/Ide/Plugin/Properties.hs --- a/src/Ide/Plugin/Properties.hs +++ b/src/Ide/Plugin/Properties.hs @@ -11,8 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- See Note [Constraints] -{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Ide.Plugin.Properties ( PropertyType (..), @@ -44,13 +42,11 @@ import Data.Either (fromRight) import Data.Function ((&)) import Data.Kind (Constraint, Type) -import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) import Data.String (IsString (fromString)) import qualified Data.Text as T import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits -import Unsafe.Coerce (unsafeCoerce) -- | Types properties may have data PropertyType @@ -114,7 +110,10 @@ -- A property is an immediate child of the json object in each plugin's "config" section. -- It was designed to be compatible with vscode's settings UI. -- Use 'emptyProperties' and 'useProperty' to create and consume 'Properties'. -newtype Properties (r :: [PropertyKey]) = Properties (Map.Map String SomePropertyKeyWithMetaData) +data Properties (r :: [PropertyKey]) where + ConsProperties :: (k ~ 'PropertyKey s t, KnownSymbol s, NotElem s ks) + => KeyNameProxy s -> (SPropertyKey k) -> (MetaData t) -> Properties ks -> Properties (k : ks) + EmptyProperties :: Properties '[] -- | A proxy type in order to allow overloaded labels as properties' names at the call site data KeyNameProxy (s :: Symbol) = KnownSymbol s => KeyNameProxy @@ -132,6 +131,10 @@ FindByKeyName s ('PropertyKey s t ': _) = t FindByKeyName s (_ ': xs) = FindByKeyName s xs +type family IsPropertySymbol (s :: Symbol) (r :: PropertyKey) :: Bool where + IsPropertySymbol s ('PropertyKey s _) = 'True + IsPropertySymbol s _ = 'False + type family Elem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where Elem s ('PropertyKey s _ ': _) = () Elem s (_ ': xs) = Elem s xs @@ -143,7 +146,17 @@ NotElem s '[] = () -- | In row @r@, there is a 'PropertyKey' @k@, which has name @s@ and carries haskell type @t@ -type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~ t, KnownSymbol s) +type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~ t, KnownSymbol s, FindPropertyMeta s r t) +class FindPropertyMeta (s :: Symbol) (r :: [PropertyKey]) t where + findSomePropertyKeyWithMetaData :: KeyNameProxy s -> Properties r -> (SPropertyKey ('PropertyKey s t), MetaData t) +instance (FindPropertyMetaIf (IsPropertySymbol symbol k) symbol k ks t) => FindPropertyMeta symbol (k : ks) t where + findSomePropertyKeyWithMetaData = findSomePropertyKeyWithMetaDataIf +class (bool ~ IsPropertySymbol symbol k) => FindPropertyMetaIf bool symbol k ks t where + findSomePropertyKeyWithMetaDataIf :: KeyNameProxy symbol -> Properties (k : ks) -> (SPropertyKey ('PropertyKey symbol t), MetaData t) +instance (k ~ 'PropertyKey s t) => FindPropertyMetaIf 'True s k ks t where + findSomePropertyKeyWithMetaDataIf _ (ConsProperties _ k m _) = (k, m) +instance ('False ~ IsPropertySymbol s k, FindPropertyMeta s ks t) => FindPropertyMetaIf 'False s k ks t where + findSomePropertyKeyWithMetaDataIf s (ConsProperties _ _ _ ks) = findSomePropertyKeyWithMetaData s ks -- --------------------------------------------------------------------- @@ -164,7 +177,7 @@ -- @ emptyProperties :: Properties '[] -emptyProperties = Properties Map.empty +emptyProperties = EmptyProperties insert :: (k ~ 'PropertyKey s t, NotElem s r, KnownSymbol s) => @@ -173,30 +186,14 @@ MetaData t -> Properties r -> Properties (k ': r) -insert kn key metadata (Properties old) = - Properties - ( Map.insert - (symbolVal kn) - (SomePropertyKeyWithMetaData key metadata) - old - ) +insert = ConsProperties find :: (HasProperty s k t r) => KeyNameProxy s -> Properties r -> (SPropertyKey k, MetaData t) -find kn (Properties p) = case p Map.! symbolVal kn of - (SomePropertyKeyWithMetaData sing metadata) -> - -- Note [Constraints] - -- It's safe to use unsafeCoerce here: - -- Since each property name is unique that the redefinition will be prevented by predication on the type level list, - -- the value we get from the name-indexed map must be exactly the singleton and metadata corresponding to the type. - -- We drop this information at type level: some of the above type families return '() :: Constraint', - -- so GHC will consider them as redundant. - -- But we encode it using semantically identical 'Map' at term level, - -- which avoids inducting on the list by defining a new type class. - unsafeCoerce (sing, metadata) +find = findSomePropertyKeyWithMetaData -- --------------------------------------------------------------------- @@ -350,7 +347,10 @@ -- | Converts a properties definition into kv pairs with default values from 'MetaData' toDefaultJSON :: Properties r -> [A.Pair] -toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p] +toDefaultJSON pr = case pr of + EmptyProperties -> [] + ConsProperties keyNameProxy k m xs -> + toEntry (symbolVal keyNameProxy) (SomePropertyKeyWithMetaData k m) : toDefaultJSON xs where toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair toEntry s = \case @@ -371,8 +371,10 @@ -- | Converts a properties definition into kv pairs as vscode schema toVSCodeExtensionSchema :: T.Text -> Properties r -> [A.Pair] -toVSCodeExtensionSchema prefix (Properties p) = - [fromString (T.unpack prefix <> k) A..= toEntry v | (k, v) <- Map.toList p] +toVSCodeExtensionSchema prefix ps = case ps of + EmptyProperties -> [] + ConsProperties (keyNameProxy :: KeyNameProxy s) (k :: SPropertyKey k) (m :: MetaData t) xs -> + fromString (T.unpack prefix <> symbolVal keyNameProxy) A..= toEntry (SomePropertyKeyWithMetaData k m) : toVSCodeExtensionSchema prefix xs where toEntry :: SomePropertyKeyWithMetaData -> A.Value toEntry = \case diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -20,7 +20,7 @@ getClientConfig, getPluginConfig, configForPlugin, - pluginEnabled, + handlesRequest, extractTextInRange, fullRange, mkLspCommand, diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -25,13 +25,14 @@ module Ide.Types ( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor , defaultPluginPriority +, describePlugin , IdeCommand(..) , IdeMethod(..) , IdeNotification(..) , IdePlugins(IdePlugins, ipMap) , DynFlagsModifications(..) , Config(..), PluginConfig(..), CheckParents(..) -, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin, pluginEnabledConfig +, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin , CustomConfig(..), mkCustomConfig , FallbackCodeActionParams(..) , FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers @@ -66,7 +67,8 @@ import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Lens (_Just, (.~), (?~), (^.), (^?)) +import Control.Lens (_Just, view, (.~), (?~), (^.), + (^?)) import Control.Monad (void) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Trans.Class (MonadTrans (lift)) @@ -95,6 +97,7 @@ import GHC (DynFlags) import GHC.Generics import Ide.Plugin.Error +import Ide.Plugin.HandleRequestTypes import Ide.Plugin.Properties import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -104,6 +107,7 @@ import Numeric.Natural import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo) +import Prettyprinter as PP import System.FilePath import System.IO.Unsafe import Text.Regex.TDFA.Text () @@ -226,6 +230,7 @@ , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool , plcFoldingRangeOn :: !Bool + , plcSemanticTokensOn :: !Bool , plcConfig :: !Object } deriving (Show,Eq) @@ -241,12 +246,13 @@ , plcCompletionOn = True , plcRenameOn = True , plcSelectionRangeOn = True - , plcFoldingRangeOn = True + , plcFoldingRangeOn = True + , plcSemanticTokensOn = True , plcConfig = mempty } instance ToJSON PluginConfig where - toJSON (PluginConfig g ch ca cl d h s c rn sr fr cfg) = r + toJSON (PluginConfig g ch ca cl d h s c rn sr fr st cfg) = r where r = object [ "globalOn" .= g , "callHierarchyOn" .= ch @@ -259,6 +265,7 @@ , "renameOn" .= rn , "selectionRangeOn" .= sr , "foldingRangeOn" .= fr + , "semanticTokensOn" .= st , "config" .= cfg ] @@ -266,6 +273,7 @@ data PluginDescriptor (ideState :: Type) = PluginDescriptor { pluginId :: !PluginId + , pluginDescription :: !T.Text -- ^ Unique identifier of the plugin. , pluginPriority :: Natural -- ^ Plugin handlers are called in priority order, higher priority first @@ -283,17 +291,14 @@ -- The file extension must have a leading '.'. } --- | Check whether the given plugin descriptor is responsible for the file with the given path. --- Compares the file extension of the file at the given path with the file extension --- the plugin is responsible for. -pluginResponsible :: Uri -> PluginDescriptor c -> Bool -pluginResponsible uri pluginDesc - | Just fp <- mfp - , T.pack (takeExtension fp) `elem` pluginFileType pluginDesc = True - | otherwise = False - where - mfp = uriToFilePath uri +describePlugin :: PluginDescriptor c -> Doc ann +describePlugin p = + let + PluginId pid = pluginId p + pdesc = pluginDescription p + in pretty pid <> ":" <> nest 4 (PP.line <> pretty pdesc) + -- | An existential wrapper of 'Properties' data CustomConfig = forall r. CustomConfig (Properties r) @@ -334,26 +339,72 @@ defaultConfigDescriptor = ConfigDescriptor Data.Default.def False (mkCustomConfig emptyProperties) +-- | Lookup the current config for a plugin +configForPlugin :: Config -> PluginDescriptor c -> PluginConfig +configForPlugin config PluginDescriptor{..} + = Map.findWithDefault (configInitialGenericConfig pluginConfigDescriptor) pluginId (plugins config) + +-- | Checks that a specific plugin is globally enabled in order to respond to +-- requests +pluginEnabledGlobally :: PluginDescriptor c -> Config -> HandleRequestResult +pluginEnabledGlobally desc conf = if plcGlobalOn (configForPlugin conf desc) + then HandlesRequest + else DoesNotHandleRequest DisabledGlobally + +-- | Checks that a specific feature for a given plugin is enabled in order +-- to respond to requests +pluginFeatureEnabled :: (PluginConfig -> Bool) -> PluginDescriptor c -> Config -> HandleRequestResult +pluginFeatureEnabled f desc conf = if f (configForPlugin conf desc) + then HandlesRequest + else DoesNotHandleRequest FeatureDisabled + +-- |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 :: L.HasData_ m (Maybe Value) => m -> PluginDescriptor c -> HandleRequestResult +pluginResolverResponsible + (view L.data_ -> (Just (fromJSON -> (Success (PluginResolveData o@(PluginId ot) _ _))))) + pluginDesc = + if pluginId pluginDesc == o + then HandlesRequest + else DoesNotHandleRequest $ NotResolveOwner ot +-- If we can't determine who this request belongs to, then we don't want any plugin +-- to handle it. +pluginResolverResponsible _ _ = DoesNotHandleRequest $ NotResolveOwner "(unable to determine resolve owner)" + +-- | Check whether the given plugin descriptor supports the file with +-- the given path. Compares the file extension from the msgParams with the +-- file extension the plugin is responsible for. +-- We are passing the msgParams here even though we only need the URI URI here. +-- If in the future we need to be able to provide only an URI it can be +-- separated again. +pluginSupportsFileType :: (L.HasTextDocument m doc, L.HasUri doc Uri) => m -> PluginDescriptor c -> HandleRequestResult +pluginSupportsFileType msgParams pluginDesc = + case mfp of + Just fp | T.pack (takeExtension fp) `elem` pluginFileType pluginDesc -> HandlesRequest + _ -> DoesNotHandleRequest $ DoesNotSupportFileType (maybe "(unable to determine file type)" (T.pack . takeExtension) mfp) + where + mfp = uriToFilePath uri + uri = msgParams ^. L.textDocument . L.uri + -- | 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 :: 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 the plugin is enabled - -- for this message in particular. - -- If a plugin is not enabled, its handlers, commands, etc. will not be - -- run for the given message. + -- | Parse the configuration to check if this plugin is globally enabled, and + -- if the feature which handles this method is enabled. Perform sanity checks + -- on the message to see whether the plugin handles this message in particular. + -- This class is only used to determine whether a plugin can handle a specific + -- request. Commands and rules do not use this logic to determine whether or + -- not they are run. -- - -- 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. There are requests - -- with no associated URI that, consequentially, cannot inspect the URI. -- - -- A common reason why a plugin might not be allowed to respond although it is enabled: + -- A common reason why a plugin won't handle a request even though 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 to Haskell and specific to [Cabal file descriptions](https://cabal.readthedocs.io/en/3.6/cabal-package.html) + -- * The resolve request is not routed to that specific plugin. Each resolve + -- request needs to be routed to only one plugin. -- -- Strictly speaking, we are conflating two concepts here: -- * Dynamically enabled (e.g. on a per-message basis) @@ -361,7 +412,7 @@ -- * Strictly speaking, this might also change dynamically -- -- But there is no use to split it up into two different methods for now. - pluginEnabled + handlesRequest :: SMethod m -- ^ Method type. -> MessageParams m @@ -373,169 +424,184 @@ -> Config -- ^ Generic config description, expected to contain 'PluginConfig' configuration -- for this plugin - -> Bool + -> HandleRequestResult -- ^ Is this plugin enabled and allowed to respond to the given request -- with the given parameters? - 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 ^. L.textDocument . L.uri - --- --------------------------------------------------------------------- --- Plugin Requests --- --------------------------------------------------------------------- + default handlesRequest :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri) + => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> HandleRequestResult + handlesRequest _ params desc conf = + pluginEnabledGlobally desc conf <> pluginSupportsFileType params desc -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 instead allow to define how to merge two hover request responses into one - -- glorious hover box. - -- - -- 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 (MessageResult m) -> MessageResult m +-- | Check if a plugin is enabled, if one of it's specific config's is enabled, +-- and if it supports the file +pluginEnabledWithFeature :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri) + => (PluginConfig -> Bool) -> SMethod m -> MessageParams m + -> PluginDescriptor c -> Config -> HandleRequestResult +pluginEnabledWithFeature feature _ msgParams pluginDesc config = + pluginEnabledGlobally pluginDesc config + <> pluginFeatureEnabled feature pluginDesc config + <> pluginSupportsFileType msgParams pluginDesc - default combineResponses :: Semigroup (MessageResult m) - => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (MessageResult m) -> MessageResult m - combineResponses _method _config _caps _params = sconcat +-- | Check if a plugin is enabled, if one of it's specific configs is enabled, +-- and if it's the plugin responsible for a resolve request. +pluginEnabledResolve :: L.HasData_ s (Maybe Value) => (PluginConfig -> Bool) -> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult +pluginEnabledResolve feature _ msgParams pluginDesc config = + pluginEnabledGlobally pluginDesc config + <> pluginFeatureEnabled feature pluginDesc config + <> pluginResolverResponsible msgParams pluginDesc instance PluginMethod Request Method_TextDocumentCodeAction where - pluginEnabled _ msgParams pluginDesc config = - pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcCodeActionsOn 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) + handlesRequest = pluginEnabledResolve plcCodeActionsOn instance PluginMethod Request Method_TextDocumentDefinition where - pluginEnabled _ msgParams pluginDesc _ = - pluginResponsible uri pluginDesc - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc instance PluginMethod Request Method_TextDocumentTypeDefinition where - pluginEnabled _ msgParams pluginDesc _ = - pluginResponsible uri pluginDesc - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc instance PluginMethod Request Method_TextDocumentDocumentHighlight where - pluginEnabled _ msgParams pluginDesc _ = - pluginResponsible uri pluginDesc - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc instance PluginMethod Request Method_TextDocumentReferences where - pluginEnabled _ msgParams pluginDesc _ = - pluginResponsible uri pluginDesc - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc instance PluginMethod Request Method_WorkspaceSymbol where -- Unconditionally enabled, but should it really be? - pluginEnabled _ _ _ _ = True + handlesRequest _ _ _ _ = HandlesRequest instance PluginMethod Request Method_TextDocumentCodeLens where - pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcCodeLensOn 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) + handlesRequest = pluginEnabledResolve plcCodeLensOn instance PluginMethod Request Method_TextDocumentRename where - pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcRenameOn + instance PluginMethod Request Method_TextDocumentHover where - pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcHoverOn (configForPlugin config pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcHoverOn instance PluginMethod Request Method_TextDocumentDocumentSymbol where - pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcSymbolsOn (configForPlugin config pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcSymbolsOn 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) + handlesRequest = pluginEnabledResolve plcCompletionOn instance PluginMethod Request Method_TextDocumentCompletion where - pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcCompletionOn instance PluginMethod Request Method_TextDocumentFormatting where - pluginEnabled SMethod_TextDocumentFormatting msgParams pluginDesc conf = - pluginResponsible uri pluginDesc - && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid) + handlesRequest _ msgParams pluginDesc conf = + (if PluginId (formattingProvider conf) == pid + || PluginId (cabalFormattingProvider conf) == pid + then HandlesRequest + else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf)) ) + <> pluginSupportsFileType msgParams pluginDesc where - uri = msgParams ^. L.textDocument . L.uri pid = pluginId pluginDesc instance PluginMethod Request Method_TextDocumentRangeFormatting where - pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid) + handlesRequest _ msgParams pluginDesc conf = + (if PluginId (formattingProvider conf) == pid + || PluginId (cabalFormattingProvider conf) == pid + then HandlesRequest + else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf))) + <> pluginSupportsFileType msgParams pluginDesc where - uri = msgParams ^. L.textDocument . L.uri pid = pluginId pluginDesc +instance PluginMethod Request Method_TextDocumentSemanticTokensFull where + handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn + instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where - pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcCallHierarchyOn instance PluginMethod Request Method_TextDocumentSelectionRange where - pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcSelectionRangeOn (configForPlugin conf pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcSelectionRangeOn instance PluginMethod Request Method_TextDocumentFoldingRange where - pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcFoldingRangeOn (configForPlugin conf pluginDesc) - where - uri = msgParams ^. L.textDocument . L.uri + handlesRequest = pluginEnabledWithFeature plcFoldingRangeOn 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) + handlesRequest _ _ pluginDesc conf = + pluginEnabledGlobally pluginDesc conf + <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf 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) + handlesRequest _ _ pluginDesc conf = + pluginEnabledGlobally pluginDesc conf + <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf instance PluginMethod Request Method_WorkspaceExecuteCommand where - pluginEnabled _ _ _ _= True + handlesRequest _ _ _ _= HandlesRequest instance PluginMethod Request (Method_CustomMethod m) where - pluginEnabled _ _ _ _ = True + handlesRequest _ _ _ _ = HandlesRequest +-- Plugin Notifications + +instance PluginMethod Notification Method_TextDocumentDidOpen where + +instance PluginMethod Notification Method_TextDocumentDidChange where + +instance PluginMethod Notification Method_TextDocumentDidSave where + +instance PluginMethod Notification Method_TextDocumentDidClose where + +instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf + +instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf + +instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf + +instance PluginMethod Notification Method_Initialized where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf + + +-- --------------------------------------------------------------------- +-- Plugin Requests +-- --------------------------------------------------------------------- + +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 instead allow to define how to merge two hover request responses into one + -- glorious hover box. + -- + -- 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 (MessageResult m) -> MessageResult m + + default combineResponses :: Semigroup (MessageResult m) + => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (MessageResult m) -> MessageResult m + combineResponses _method _config _caps _params = sconcat + + + --- instance PluginRequestMethod Method_TextDocumentCodeAction where combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = @@ -691,6 +757,9 @@ instance PluginRequestMethod (Method_CustomMethod m) where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where + combineResponses _ _ _ _ (x :| _) = x + takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) @@ -746,31 +815,6 @@ class PluginMethod Notification m => PluginNotificationMethod (m :: Method ClientToServer Notification) where -instance PluginMethod Notification Method_TextDocumentDidOpen where - -instance PluginMethod Notification Method_TextDocumentDidChange where - -instance PluginMethod Notification Method_TextDocumentDidSave where - -instance PluginMethod Notification Method_TextDocumentDidClose 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 Method_WorkspaceDidChangeWorkspaceFolders where - -- This method has no URI parameter, thus no call to 'pluginResponsible'. - pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc - -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 Method_Initialized where - -- This method has no URI parameter, thus no call to 'pluginResponsible'. - pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc - - instance PluginNotificationMethod Method_TextDocumentDidOpen where instance PluginNotificationMethod Method_TextDocumentDidChange where @@ -894,10 +938,11 @@ -- -- and handlers will be enabled for files with the appropriate file -- extensions. -defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState -defaultPluginDescriptor plId = +defaultPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState +defaultPluginDescriptor plId desc = PluginDescriptor plId + desc defaultPluginPriority mempty mempty @@ -914,10 +959,11 @@ -- -- Handles files with the following extensions: -- * @.cabal@ -defaultCabalPluginDescriptor :: PluginId -> PluginDescriptor ideState -defaultCabalPluginDescriptor plId = +defaultCabalPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState +defaultCabalPluginDescriptor plId desc = PluginDescriptor plId + desc defaultPluginPriority mempty mempty @@ -965,7 +1011,7 @@ -> PluginHandlers ideState mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do case fromJSON <$> (params ^. L.data_) of - (Just (Success (PluginResolveData owner uri value) )) -> do + (Just (Success (PluginResolveData owner@(PluginId ownerName) uri value) )) -> do if owner == plId then case fromJSON value of @@ -975,7 +1021,8 @@ 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))) + throwError (PluginRequestRefused + (NotResolveOwner (ownerName <> ": error decoding payload:" <> T.pack 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 @@ -1011,16 +1058,7 @@ instance IsString PluginId where fromString = PluginId . T.pack --- | Lookup the current config for a plugin -configForPlugin :: Config -> PluginDescriptor c -> PluginConfig -configForPlugin config PluginDescriptor{..} - = Map.findWithDefault (configInitialGenericConfig pluginConfigDescriptor) pluginId (plugins config) --- | Checks that a given plugin is both enabled and the specific feature is --- enabled -pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginConfig -> Bool -pluginEnabledConfig f pluginConfig = plcGlobalOn pluginConfig && f pluginConfig - -- --------------------------------------------------------------------- -- | Format the given Text as a whole or only a @Range@ of it. @@ -1143,14 +1181,6 @@ 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,