diff --git a/exe/Plugins.hs b/exe/Plugins.hs index dead73452c..07c15eb7f2 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -13,6 +13,7 @@ import Development.IDE (IdeState) import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Ide.Plugin.Example as Example import qualified Ide.Plugin.Example2 as Example2 +import qualified Ide.Plugin.ExampleCabal as ExampleCabal -- haskell-language-server optional plugins #if qualifyImportedNames @@ -204,4 +205,5 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins examplePlugins = [Example.descriptor pluginRecorder "eg" ,Example2.descriptor pluginRecorder "eg2" + ,ExampleCabal.descriptor pluginRecorder "ec" ] diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 7c8c7cec68..1959dd8dcd 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -58,8 +58,8 @@ asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin C asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> - mkPlugin extensiblePlugins HLS.pluginHandlers <> - mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <> + mkPlugin (extensiblePlugins recorder) id <> + mkPlugin (extensibleNotificationPlugins recorder) id <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where @@ -153,55 +153,66 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd -- --------------------------------------------------------------------- -extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config -extensiblePlugins xs = mempty { P.pluginHandlers = handlers } +extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config +extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers - bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map - (\(PluginHandler f) -> IdeHandler [(pid,f pid)]) + bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers + bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map + (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)]) hs + where + PluginHandlers hs = HLS.pluginHandlers pluginDesc handlers = mconcat $ do (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' pure $ requestHandler m $ \ide params -> do config <- Ide.PluginUtils.getClientConfig - let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' + -- Only run plugins that are allowed to run on this request + let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' case nonEmpty fs of - Nothing -> pure $ Left $ ResponseError InvalidRequest - ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs)) - Nothing + Nothing -> do + logWith recorder Info LogNoEnabledPlugins + pure $ Left $ ResponseError InvalidRequest + ( "No plugin enabled for " <> T.pack (show m) + <> ", available: " <> T.pack (show $ map (\(plid,_,_) -> plid) fs) + ) + Nothing Just fs -> do let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - es <- runConcurrently msg (show m) fs ide params + handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs + es <- runConcurrently msg (show m) handlers ide params let (errs,succs) = partitionEithers $ toList es case nonEmpty succs of Nothing -> pure $ Left $ combineErrors errs Just xs -> do caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs + -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config +extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeNotificationHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers - bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map - (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)]) + bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers + bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map + (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,pluginDesc,f pid)]) hs + where PluginNotificationHandlers hs = HLS.pluginNotificationHandlers pluginDesc handlers = mconcat $ do (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers' pure $ notificationHandler m $ \ide vfs params -> do config <- Ide.PluginUtils.getClientConfig - let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs' + -- Only run plugins that are allowed to run on this request + let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' case nonEmpty fs of Nothing -> do - logWith recorder Info LogNoEnabledPlugins - pure () + logWith recorder Info LogNoEnabledPlugins + pure () Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last - mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs + mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs -- --------------------------------------------------------------------- @@ -210,6 +221,7 @@ runConcurrently => (SomeException -> PluginId -> T.Text) -> String -- ^ label -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + -- ^ Enabled plugin actions that we are allowed to run -> a -> b -> m (NonEmpty (Either ResponseError d)) @@ -223,11 +235,11 @@ combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing -- | Combine the 'PluginHandler' for all plugins newtype IdeHandler (m :: J.Method FromClient Request) - = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] + = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: J.Method FromClient Notification) - = IdeNotificationHandler [(PluginId, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] + = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] -- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()` -- | Combine the 'PluginHandlers' for all plugins diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index f19b732cdc..b44e865083 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -6721,7 +6721,7 @@ unitTests recorder logger = do ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do - _ <- createDoc "haskell" "A.hs" "module A where" + _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 97ecfa8269..cf63af660d 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -226,7 +226,8 @@ flag dynamic common example-plugins hs-source-dirs: plugins/default/src other-modules: Ide.Plugin.Example, - Ide.Plugin.Example2 + Ide.Plugin.Example2, + Ide.Plugin.ExampleCabal common class if flag(class) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index d8e3b491d8..301b0cd233 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -43,6 +43,7 @@ library , Diff ^>=0.4.0 , dlist , extra + , filepath , ghc , hashable , hls-graph ^>= 1.7 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index a8c65bb6e4..7d60fd281d 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Ide.Types where @@ -69,6 +70,7 @@ import Language.LSP.Types.Lens as J (HasChildren (children), import Language.LSP.VFS import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo) +import System.FilePath import System.IO.Unsafe import Text.Regex.TDFA.Text () @@ -108,8 +110,9 @@ instance Show (IdeCommand st) where show _ = "" -- --------------------------------------------------------------------- -data PluginDescriptor ideState = +data PluginDescriptor (ideState :: *) = PluginDescriptor { pluginId :: !PluginId + -- ^ Unique identifier of the plugin. , pluginRules :: !(Rules ()) , pluginCommands :: ![PluginCommand ideState] , pluginHandlers :: PluginHandlers ideState @@ -117,13 +120,30 @@ data PluginDescriptor ideState = , 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 +156,7 @@ data CustomConfig = forall r. CustomConfig (Properties r) -- } -- } -- @ +-- -- @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 +180,67 @@ defaultConfigDescriptor = ConfigDescriptor True False (mkCustomConfig emptyPrope -- | 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. + -- 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? + + 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 - -- | Parse the configuration to check if this plugin is enabled - pluginEnabled :: SMethod m -> PluginId -> Config -> Bool +-- --------------------------------------------------------------------- +-- Plugin Requests +-- --------------------------------------------------------------------- - -- | How to combine responses from different plugins +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 +252,16 @@ class HasTracing (MessageParams m) => PluginMethod m where => 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,31 +285,124 @@ instance PluginMethod TextDocumentCodeAction where , Just caKind <- ca ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed | otherwise = False -instance PluginMethod TextDocumentDefinition where - pluginEnabled _ _ _ = True - combineResponses _ _ _ _ (x :| _) = x +instance PluginMethod Request TextDocumentDefinition where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri -instance PluginMethod TextDocumentTypeDefinition where - pluginEnabled _ _ _ = True - combineResponses _ _ _ _ (x :| _) = x +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 TextDocumentDocumentHighlight where - pluginEnabled _ _ _ = True +instance PluginMethod Request CustomMethod where + pluginEnabled _ _ _ _ = True + +--- +instance PluginRequestMethod TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod TextDocumentReferences where - pluginEnabled _ _ _ = True +instance PluginRequestMethod TextDocumentTypeDefinition where combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod WorkspaceSymbol where - pluginEnabled _ _ _ = True +instance PluginRequestMethod TextDocumentDocumentHighlight where + +instance PluginRequestMethod TextDocumentReferences where + +instance PluginRequestMethod WorkspaceSymbol where + +instance PluginRequestMethod TextDocumentCodeLens where + +instance PluginRequestMethod TextDocumentRename where -instance PluginMethod TextDocumentCodeLens where - pluginEnabled _ = pluginEnabledConfig plcCodeLensOn -instance PluginMethod TextDocumentRename where - pluginEnabled _ = pluginEnabledConfig plcRenameOn -instance PluginMethod TextDocumentHover where - pluginEnabled _ = pluginEnabledConfig plcHoverOn +instance PluginRequestMethod TextDocumentHover where combineResponses _ _ _ _ (catMaybes . toList -> hs) = h where r = listToMaybe $ mapMaybe (^. range) hs @@ -237,8 +410,7 @@ instance PluginMethod TextDocumentHover where 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 @@ -259,8 +431,7 @@ instance PluginMethod TextDocumentDocumentSymbol where 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 @@ -288,42 +459,85 @@ instance PluginMethod TextDocumentCompletion where 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 @@ -362,7 +576,7 @@ type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams -- | Make a handler for plugins with no extra data mkPluginHandler - :: PluginMethod m + :: PluginRequestMethod m => SClientMethod m -> PluginMethodHandler ideState m -> PluginHandlers ideState @@ -372,7 +586,7 @@ mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandl -- | 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 @@ -381,6 +595,15 @@ mkPluginNotificationHandler m f where f' pid ide vfs = f ide vfs pid +-- | 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 @@ -392,6 +615,26 @@ defaultPluginDescriptor plId = 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 + mempty + mempty + mempty + defaultConfigDescriptor + mempty + mempty + Nothing + [".cabal"] newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) diff --git a/plugins/default/src/Ide/Plugin/ExampleCabal.hs b/plugins/default/src/Ide/Plugin/ExampleCabal.hs new file mode 100644 index 0000000000..74f7982393 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/ExampleCabal.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.ExampleCabal where + +import Control.Monad.IO.Class +import Data.Aeson +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T +import Development.IDE as D hiding (pluginHandlers) +import GHC.Generics +import Ide.PluginUtils +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types + +newtype Log = LogText T.Text deriving Show + +instance Pretty Log where + pretty = \case + LogText log -> pretty log + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultCabalPluginDescriptor plId) + { pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] + , pluginHandlers = mkPluginHandler STextDocumentCodeLens (codeLens recorder) + } + +-- --------------------------------------------------------------------- + +codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeLens +codeLens recorder _ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = liftIO $ do + log Debug $ LogText "ExampleCabal.codeLens entered (ideLogger)" + case uriToFilePath' uri of + Just (toNormalizedFilePath -> _filePath) -> do + let + title = "Add TODO Item via Code Lens" + range = Range (Position 3 0) (Position 4 0) + let cmdParams = AddTodoParams uri "do abc" + cmd = mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) + pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] + Nothing -> pure $ Right $ List [] + where + log = logWith recorder + +-- --------------------------------------------------------------------- +-- | Parameters for the addTodo PluginCommand. +data AddTodoParams = AddTodoParams + { file :: Uri -- ^ Uri of the file to add the pragma to + , todoText :: T.Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +addTodoCmd :: CommandFunction IdeState AddTodoParams +addTodoCmd _ide (AddTodoParams uri todoText) = do + let + pos = Position 5 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO2:" <> todoText <> "\n") + ] + res = WorkspaceEdit + (Just $ Map.singleton uri textEdits) + Nothing + Nothing + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) + return $ Right Null