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: 1.4.0.0 +version: 1.5.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at @@ -39,17 +39,18 @@ , containers , data-default , dependent-map - , dependent-sum + , dependent-sum >=0.7 , Diff ^>=0.4.0 , dlist , extra + , filepath , ghc , hashable - , hls-graph ^>= 1.7 + , hls-graph ^>= 1.8 , lens , lens-aeson - , lsp >=1.4.0.0 && < 1.6 - , opentelemetry + , lsp ^>=1.6.0.0 + , opentelemetry >=0.4 , optparse-applicative , process , regex-tdfa >=1.3.1.0 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 @@ -34,7 +34,7 @@ A.toJSON defaultConfig & ix "haskell" . _Object . at "plugin" ?~ elems where defaultConfig@Config {} = def - elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap + elems = A.object $ mconcat $ singlePlugin <$> ipMap -- Splice genericDefaultConfig and dedicatedDefaultConfig -- Example: -- @@ -96,7 +96,7 @@ -- | Generates json schema used in haskell vscode extension -- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value -pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap +pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> ipMap where singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = genericSchema <> dedicatedSchema where diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -28,22 +28,23 @@ positionInRange, usePropertyLsp, getNormalizedFilePath, - response, + pluginResponse, handleMaybe, handleMaybeM, + throwPluginError, ) where -import Control.Lens ((^.)) +import Control.Arrow ((&&&)) import Control.Monad.Extra (maybeM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Bifunctor (Bifunctor (first)) -import Data.Containers.ListUtils (nubOrdOn) import qualified Data.HashMap.Strict as H +import Data.List (find) import Data.String (IsString (fromString)) import qualified Data.Text as T import Ide.Plugin.Config @@ -56,7 +57,6 @@ SemanticTokensEdit (_start)) import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities -import Language.LSP.Types.Lens (uri) -- --------------------------------------------------------------------- @@ -160,11 +160,10 @@ -- --------------------------------------------------------------------- pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState -pluginDescToIdePlugins plugins = - IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins +pluginDescToIdePlugins = IdePlugins idePluginsToPluginDesc :: IdePlugins ideState -> [PluginDescriptor ideState] -idePluginsToPluginDesc (IdePlugins pp) = map snd pp +idePluginsToPluginDesc (IdePlugins pp) = pp -- --------------------------------------------------------------------- -- | Returns the current client configuration. It is not wise to permanently @@ -219,49 +218,40 @@ lastLine = fromIntegral $ length $ T.lines s subRange :: Range -> Range -> Bool -subRange smallRange range = - positionInRange (_start smallRange) range - && positionInRange (_end smallRange) range - -positionInRange :: Position -> Range -> Bool -positionInRange p (Range sp ep) = sp <= p && p <= ep +subRange = isSubrangeOf -- --------------------------------------------------------------------- allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text] -allLspCmdIds' pid (IdePlugins ls) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) - where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - - - mkPlugin maker selector - = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls - +allLspCmdIds' pid (IdePlugins 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 => PluginId -> TextDocumentIdentifier -> ExceptT String m NormalizedFilePath -getNormalizedFilePath (PluginId plId) docId = handleMaybe errMsg +getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath +getNormalizedFilePath uri = handleMaybe errMsg $ uriToNormalizedFilePath - $ toNormalizedUri uri' + $ toNormalizedUri uri where - errMsg = T.unpack $ "Error(" <> plId <> "): converting " <> getUri uri' <> " to NormalizedFilePath" - uri' = docId ^. uri + 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 -response :: Monad m => ExceptT String m a -> m (Either ResponseError a) -response = +pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a) +pluginResponse = fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) . runExceptT diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -9,8 +9,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,6 +21,32 @@ {-# LANGUAGE ViewPatterns #-} module Ide.Types +( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor +, defaultPluginPriority +, IdeCommand(..) +, IdeMethod(..) +, IdeNotification(..) +, IdePlugins(IdePlugins, ipMap) +, DynFlagsModifications(..) +, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin, pluginEnabledConfig +, CustomConfig(..), mkCustomConfig +, FallbackCodeActionParams(..) +, FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers +, HasTracing(..) +, PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId +, PluginId(..) +, PluginHandler(..), mkPluginHandler +, PluginHandlers(..) +, PluginMethod(..) +, PluginMethodHandler +, PluginNotificationHandler(..), mkPluginNotificationHandler +, PluginNotificationHandlers(..) +, PluginRequestMethod(..) +, getProcessID, getPid +, installSigUsr1Handler +, responseError +, lookupCommandProvider +) where #ifdef mingw32_HOST_OS @@ -28,16 +56,22 @@ import qualified System.Posix.Process as P (getProcessID) import System.Posix.Signals #endif +import Control.Arrow ((&&&)) import Control.Lens ((^.)) import Data.Aeson hiding (defaultOptions) -import qualified Data.DList as DList import qualified Data.Default 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 (sortOn, find) 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 @@ -67,17 +101,42 @@ HasTitle (title), HasUri (..)) import Language.LSP.VFS +import Numeric.Natural import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo) +import System.FilePath import System.IO.Unsafe import Text.Regex.TDFA.Text () +import Control.Applicative ((<|>)) -- --------------------------------------------------------------------- -newtype IdePlugins ideState = IdePlugins - { ipMap :: [(PluginId, PluginDescriptor ideState)]} - deriving newtype (Monoid, Semigroup) +data IdePlugins ideState = IdePlugins_ + { ipMap_ :: HashMap PluginId (PluginDescriptor ideState) + , lookupCommandProvider :: CommandId -> Maybe PluginId + } +-- | Smart constructor that deduplicates plugins +pattern IdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState +pattern IdePlugins{ipMap} <- IdePlugins_ (sortOn (Down . pluginPriority) . HashMap.elems -> ipMap) _ + where + IdePlugins ipMap = IdePlugins_{ipMap_ = HashMap.fromList $ (pluginId &&& id) <$> ipMap + , lookupCommandProvider = lookupPluginId ipMap + } +{-# COMPLETE IdePlugins #-} + +instance Semigroup (IdePlugins a) where + (IdePlugins_ a f) <> (IdePlugins_ b g) = IdePlugins_ (a <> b) (\x -> f x <|> g x) + +instance Monoid (IdePlugins a) where + mempty = IdePlugins_ mempty (const Nothing) + +-- | Lookup the plugin that exposes a particular command +lookupPluginId :: [PluginDescriptor a] -> CommandId -> Maybe PluginId +lookupPluginId ls cmd = pluginId <$> find go ls + where + go desc = cmd `elem` map commandId (pluginCommands desc) + -- | Hooks for modifying the 'DynFlags' at different times of the compilation -- process. Plugins can install a 'DynFlagsModifications' via -- 'pluginModifyDynflags' in their 'PluginDescriptor'. @@ -108,8 +167,11 @@ -- --------------------------------------------------------------------- -data PluginDescriptor ideState = +data PluginDescriptor (ideState :: *) = PluginDescriptor { pluginId :: !PluginId + -- ^ Unique identifier of the plugin. + , pluginPriority :: Natural + -- ^ Plugin handlers are called in priority order, higher priority first , pluginRules :: !(Rules ()) , pluginCommands :: ![PluginCommand ideState] , pluginHandlers :: PluginHandlers ideState @@ -117,13 +179,30 @@ , pluginNotificationHandlers :: PluginNotificationHandlers ideState , pluginModifyDynflags :: DynFlagsModifications , 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 + -- 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 '.'. } +-- | 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 + -- | 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: +-- -- @ -- { -- "plugin-id": { @@ -136,6 +215,7 @@ -- } -- } -- @ +-- -- @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'. @@ -159,12 +239,67 @@ -- | 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 m where +class HasTracing (MessageParams m) => PluginMethod (k :: MethodType) (m :: Method FromClient k) where - -- | Parse the configuration to check if this plugin is enabled - pluginEnabled :: SMethod m -> PluginId -> Config -> Bool + -- | Parse the configuration to check if this plugin is enabled. + -- Perform sanity checks on the message to see whether 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. + -- + -- Semantically, this method described 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. + -- + -- 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 + -- * 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) + -- + -- Strictly speaking, we are conflating two concepts here: + -- * Dynamically enabled (e.g. enabled 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. + 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 + -> PluginDescriptor c + -- ^ Contains meta information such as PluginId and what file types this + -- plugin is able to handle. + -> Config + -- ^ Generic config description, expected to hold 'PluginConfig' configuration + -- for this plugin + -> Bool + -- ^ Is this plugin enabled and allowed to respond to the given request + -- with the given parameters? - -- | How to combine responses from different plugins + default pluginEnabled :: (HasTextDocument (MessageParams m) doc, HasUri doc Uri) + => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool + pluginEnabled _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf (pluginId desc)) + where + uri = params ^. J.textDocument . J.uri + +-- --------------------------------------------------------------------- +-- Plugin Requests +-- --------------------------------------------------------------------- + +class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient 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 + -- glorious hover box. + -- + -- However, 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 @@ -176,12 +311,16 @@ => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m combineResponses _method _config _caps _params = sconcat -instance PluginMethod TextDocumentCodeAction where - pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn +instance PluginMethod Request TextDocumentCodeAction where + pluginEnabled _ msgParams pluginDesc config = + pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (pluginId pluginDesc) config + 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) @@ -205,12 +344,124 @@ , Just caKind <- ca ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed | otherwise = False -instance PluginMethod TextDocumentCodeLens where - pluginEnabled _ = pluginEnabledConfig plcCodeLensOn -instance PluginMethod TextDocumentRename where - pluginEnabled _ = pluginEnabledConfig plcRenameOn -instance PluginMethod TextDocumentHover where - pluginEnabled _ = pluginEnabledConfig plcHoverOn +instance PluginMethod Request TextDocumentDefinition where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request TextDocumentTypeDefinition where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request TextDocumentDocumentHighlight where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request TextDocumentReferences where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request WorkspaceSymbol where + -- Unconditionally enabled, but should it really be? + pluginEnabled _ _ _ _ = True + +instance PluginMethod Request TextDocumentCodeLens where + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcCodeLensOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request TextDocumentRename where + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcRenameOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri +instance PluginMethod Request TextDocumentHover where + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcHoverOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request TextDocumentDocumentSymbol where + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcSymbolsOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request TextDocumentCompletion where + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcCompletionOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod Request TextDocumentFormatting where + pluginEnabled STextDocumentFormatting msgParams pluginDesc conf = + pluginResponsible uri pluginDesc && PluginId (formattingProvider conf) == pid + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc + +instance PluginMethod Request TextDocumentRangeFormatting where + pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc + && PluginId (formattingProvider conf) == pid + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc + +instance PluginMethod Request TextDocumentPrepareCallHierarchy where + pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcCallHierarchyOn pid conf + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc + +instance PluginMethod Request TextDocumentSelectionRange where + pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcSelectionRangeOn pid conf + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc + +instance PluginMethod Request CallHierarchyIncomingCalls where + -- This method has no URI parameter, thus no call to 'pluginResponsible' + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf + where + pid = pluginId pluginDesc + +instance PluginMethod Request CallHierarchyOutgoingCalls where + -- This method has no URI parameter, thus no call to 'pluginResponsible' + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf + where + pid = pluginId pluginDesc + +instance PluginMethod Request CustomMethod where + pluginEnabled _ _ _ _ = True + +--- +instance PluginRequestMethod TextDocumentDefinition where + combineResponses _ _ _ _ (x :| _) = x + +instance PluginRequestMethod TextDocumentTypeDefinition where + combineResponses _ _ _ _ (x :| _) = x + +instance PluginRequestMethod TextDocumentDocumentHighlight where + +instance PluginRequestMethod TextDocumentReferences where + +instance PluginRequestMethod WorkspaceSymbol where + +instance PluginRequestMethod TextDocumentCodeLens where + +instance PluginRequestMethod TextDocumentRename where + +instance PluginRequestMethod TextDocumentHover where combineResponses _ _ _ _ (catMaybes . toList -> hs) = h where r = listToMaybe $ mapMaybe (^. range) hs @@ -218,8 +469,7 @@ HoverContentsMS (List []) -> Nothing hh -> Just $ Hover hh r -instance PluginMethod TextDocumentDocumentSymbol where - pluginEnabled _ = pluginEnabledConfig plcSymbolsOn +instance PluginRequestMethod TextDocumentDocumentSymbol where combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res where uri' = params ^. textDocument . uri @@ -240,8 +490,7 @@ si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent in [si] <> children' -instance PluginMethod TextDocumentCompletion where - pluginEnabled _ = pluginEnabledConfig plcCompletionOn +instance PluginRequestMethod TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where limit = maxCompletions conf @@ -269,42 +518,85 @@ consumeCompletionResponse n (InL (List xx)) = consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx))) -instance PluginMethod TextDocumentFormatting where - pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid +instance PluginRequestMethod TextDocumentFormatting where combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod TextDocumentRangeFormatting where - pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid +instance PluginRequestMethod TextDocumentRangeFormatting where combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod TextDocumentPrepareCallHierarchy where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn +instance PluginRequestMethod TextDocumentPrepareCallHierarchy where -instance PluginMethod TextDocumentSelectionRange where - pluginEnabled _ = pluginEnabledConfig plcSelectionRangeOn +instance PluginRequestMethod TextDocumentSelectionRange where combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod CallHierarchyIncomingCalls where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn +instance PluginRequestMethod CallHierarchyIncomingCalls where -instance PluginMethod CallHierarchyOutgoingCalls where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn +instance PluginRequestMethod CallHierarchyOutgoingCalls where -instance PluginMethod CustomMethod where - pluginEnabled _ _ _ = True +instance PluginRequestMethod CustomMethod where combineResponses _ _ _ _ (x :| _) = x -- --------------------------------------------------------------------- +-- 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 + + +instance PluginMethod Notification TextDocumentDidOpen where + +instance PluginMethod Notification TextDocumentDidChange where + +instance PluginMethod Notification TextDocumentDidSave where + +instance PluginMethod Notification TextDocumentDidClose where + +instance PluginMethod Notification WorkspaceDidChangeWatchedFiles where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginMethod Notification WorkspaceDidChangeWorkspaceFolders where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginMethod Notification WorkspaceDidChangeConfiguration where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginMethod Notification Initialized where + -- This method has no URI parameter, thus no call to 'pluginResponsible'. + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + + +instance PluginNotificationMethod TextDocumentDidOpen where + +instance PluginNotificationMethod TextDocumentDidChange where + +instance PluginNotificationMethod TextDocumentDidSave where + +instance PluginNotificationMethod TextDocumentDidClose where + +instance PluginNotificationMethod WorkspaceDidChangeWatchedFiles where + +instance PluginNotificationMethod WorkspaceDidChangeWorkspaceFolders where + +instance PluginNotificationMethod WorkspaceDidChangeConfiguration where + +instance PluginNotificationMethod Initialized where + +-- --------------------------------------------------------------------- + -- | Methods which have a PluginMethod instance -data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m) +data IdeMethod (m :: Method FromClient 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) = HasTracing (MessageParams m) => IdeNotification (SMethod m) +data IdeNotification (m :: Method FromClient Notification) = PluginNotificationMethod m => IdeNotification (SMethod m) instance GEq IdeNotification where geq (IdeNotification a) (IdeNotification b) = geq a b instance GCompare IdeNotification where @@ -343,7 +635,7 @@ -- | Make a handler for plugins with no extra data mkPluginHandler - :: PluginMethod m + :: PluginRequestMethod m => SClientMethod m -> PluginMethodHandler ideState m -> PluginHandlers ideState @@ -353,7 +645,7 @@ -- | Make a handler for plugins with no extra data mkPluginNotificationHandler - :: HasTracing (MessageParams m) + :: PluginNotificationMethod m => SClientMethod (m :: Method FromClient Notification) -> PluginNotificationMethodHandler ideState m -> PluginNotificationHandlers ideState @@ -362,10 +654,23 @@ where f' pid ide vfs = f ide vfs pid +defaultPluginPriority :: Natural +defaultPluginPriority = 1000 + +-- | Set up a plugin descriptor, initialized with default values. +-- This is plugin descriptor is prepared for @haskell@ files, such as +-- +-- * @.hs@ +-- * @.lhs@ +-- * @.hs-boot@ +-- +-- and handlers will be enabled for files with the appropriate file +-- extensions. defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState defaultPluginDescriptor plId = PluginDescriptor plId + defaultPluginPriority mempty mempty mempty @@ -373,7 +678,28 @@ mempty mempty Nothing + [".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, +-- will only respond / run when @.cabal@ files are currently in scope. +-- +-- Handles files with the following extensions: +-- * @.cabal@ +defaultCabalPluginDescriptor :: PluginId -> PluginDescriptor ideState +defaultCabalPluginDescriptor plId = + PluginDescriptor + plId + defaultPluginPriority + mempty + mempty + mempty + defaultConfigDescriptor + mempty + mempty + Nothing + [".cabal"] + newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) instance IsString CommandId where @@ -396,6 +722,7 @@ newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) + deriving newtype (FromJSON, Hashable) instance IsString PluginId where fromString = PluginId . T.pack diff --git a/test/Ide/PluginUtilsTest.hs b/test/Ide/PluginUtilsTest.hs --- a/test/Ide/PluginUtilsTest.hs +++ b/test/Ide/PluginUtilsTest.hs @@ -9,19 +9,5 @@ tests :: TestTree tests = testGroup "PluginUtils" - [ positionInRangeTest - ] - -positionInRangeTest :: TestTree -positionInRangeTest = testGroup "positionInRange" - [ testCase "single line, after the end" $ - positionInRange (Position 1 10) (Range (Position 1 1) (Position 1 3)) @?= False - , testCase "single line, before the begining" $ - positionInRange (Position 1 0) (Range (Position 1 1) (Position 1 6)) @?= False - , testCase "single line, in range" $ - positionInRange (Position 1 5) (Range (Position 1 1) (Position 1 6)) @?= True - , testCase "multiline, in range" $ - positionInRange (Position 3 5) (Range (Position 1 1) (Position 5 6)) @?= True - , testCase "multiline, out of range" $ - positionInRange (Position 3 5) (Range (Position 3 6) (Position 4 10)) @?= False + [ ]